Skip to content

R
riscv-gcc-1
Commit 30a5fd0b by Jerome Lambourg Committed by Pierre-Marie de Rodat
Options

[Ada] Remove vxlink and vxaddr2line from this repository 

Those tools need a dedicated repository as they're VxWorks specific and
not related with the Ada front-end.

2018-12-11  Jerome Lambourg  <lambourg@adacore.com>

gcc/ada/

	* vxaddr2line.adb, vxlink-bind.adb, vxlink-bind.ads,
	vxlink-link.adb, vxlink-link.ads, vxlink-main.adb, vxlink.adb,
	vxlink.ads: Remove.
	* gcc-interface/Make-lang.in, gcc-interface/Makefile.in: Remove
	bits for vxaddr2line.

From-SVN: r266995
parent 2401c98f
Showing with 8 additions and 1723 deletions
gcc/ada/ChangeLog
2018-12-11 Jerome Lambourg <lambourg@adacore.com>
* vxaddr2line.adb, vxlink-bind.adb, vxlink-bind.ads,
vxlink-link.adb, vxlink-link.ads, vxlink-main.adb, vxlink.adb,
vxlink.ads: Remove.
* gcc-interface/Make-lang.in, gcc-interface/Makefile.in: Remove
bits for vxaddr2line.
2018-12-11 Hristian Kirtchev <kirtchev@adacore.com> 2018-12-11 Hristian Kirtchev <kirtchev@adacore.com>
* exp_aggr.adb, exp_ch7.adb, gnat1drv.adb, sem_ch10.adb, * exp_aggr.adb, exp_ch7.adb, gnat1drv.adb, sem_ch10.adb,
......
gcc/ada/gcc-interface/Make-lang.in
...@@ -675,12 +675,10 @@ regnattools: ...@@ -675,12 +675,10 @@ regnattools:
cross-gnattools: force cross-gnattools: force
$(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools1-re $(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools1-re
$(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools2 $(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools2
$(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools4
canadian-gnattools: force canadian-gnattools: force
$(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools1-re $(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools1-re
$(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools2 $(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools2
$(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools4
gnatlib gnatlib-sjlj gnatlib-zcx gnatlib-shared: force gnatlib gnatlib-sjlj gnatlib-zcx gnatlib-shared: force
$(MAKE) -C ada $(COMMON_FLAGS_TO_PASS) \ $(MAKE) -C ada $(COMMON_FLAGS_TO_PASS) \
...@@ -811,8 +809,6 @@ doc/gnat-style.pdf: ada/gnat-style.texi $(gcc_docdir)/include/fdl.texi ...@@ -811,8 +809,6 @@ doc/gnat-style.pdf: ada/gnat-style.texi $(gcc_docdir)/include/fdl.texi
# gnatlink, gnatls, gnatmake, gnatname, gnatprep, gnatxref, gnatfind, # gnatlink, gnatls, gnatmake, gnatname, gnatprep, gnatxref, gnatfind,
# gnatclean). # gnatclean).
# gnatdll is only used on Windows. # gnatdll is only used on Windows.
# vxaddr2line is only used for cross VxWorks ports (it calls the underlying
# cross addr2line).
ada.install-common: ada.install-common:
$(MKDIR) $(DESTDIR)$(bindir) $(MKDIR) $(DESTDIR)$(bindir)
-if [ -f gnat1$(exeext) ] ; \ -if [ -f gnat1$(exeext) ] ; \
...@@ -829,11 +825,6 @@ ada.install-common: ...@@ -829,11 +825,6 @@ ada.install-common:
done; \ done; \
$(RM) $(DESTDIR)$(bindir)/gnatdll$(exeext); \ $(RM) $(DESTDIR)$(bindir)/gnatdll$(exeext); \
$(INSTALL_PROGRAM) gnatdll$(exeext) $(DESTDIR)$(bindir)/gnatdll$(exeext); \ $(INSTALL_PROGRAM) gnatdll$(exeext) $(DESTDIR)$(bindir)/gnatdll$(exeext); \
if [ -f vxaddr2line$(exeext) ] ; \
then \
$(RM) $(DESTDIR)$(bindir)/vxaddr2line$(exeext); \
$(INSTALL_PROGRAM) vxaddr2line$(exeext) $(DESTDIR)$(bindir)/vxaddr2line$(exeext); \
fi ; \
fi fi
# #
...@@ -859,7 +850,6 @@ ada.uninstall: ...@@ -859,7 +850,6 @@ ada.uninstall:
-$(RM) $(DESTDIR)$(bindir)/$$install_name; \ -$(RM) $(DESTDIR)$(bindir)/$$install_name; \
done done
-$(RM) $(DESTDIR)$(tooldir)/bin/gnatdll$(exeext) -$(RM) $(DESTDIR)$(tooldir)/bin/gnatdll$(exeext)
-$(RM) $(DESTDIR)$(tooldir)/bin/vxaddr2line$(exeext)
# Clean hooks: # Clean hooks:
# A lot of the ancillary files are deleted by the main makefile. # A lot of the ancillary files are deleted by the main makefile.
......
gcc/ada/gcc-interface/Makefile.in
...@@ -434,19 +434,6 @@ gnattools2: ../stamp-tools ...@@ -434,19 +434,6 @@ gnattools2: ../stamp-tools
$(MAKE) -C tools -f ../Makefile $(TOOLS_FLAGS_TO_PASS) \ $(MAKE) -C tools -f ../Makefile $(TOOLS_FLAGS_TO_PASS) \
TOOLSCASE=native common-tools $(EXTRA_GNATTOOLS) TOOLSCASE=native common-tools $(EXTRA_GNATTOOLS)
# those tools are only built for the cross version
gnattools4: ../stamp-tools
ifeq ($(ENABLE_VXADDR2LINE),true)
$(MAKE) -C tools -f ../Makefile $(TOOLS_FLAGS_TO_PASS) \
TOOLSCASE=cross top_buildir=../../.. \
../../vxaddr2line$(exeext)
endif
ifeq ($(ENABLE_VXLINK),true)
$(MAKE) -C tools -f ../Makefile $(TOOLS_FLAGS_TO_PASS) \
TOOLSCASE=cross top_build=../../.. \
../../vxlink$(exeext)
endif
common-tools: ../stamp-tools common-tools: ../stamp-tools
$(GNATMAKE) -j0 -c -b $(ADA_INCLUDES) \ $(GNATMAKE) -j0 -c -b $(ADA_INCLUDES) \
--GNATBIND="$(GNATBIND)" --GCC="$(CC) $(ALL_ADAFLAGS)" \ --GNATBIND="$(GNATBIND)" --GCC="$(CC) $(ALL_ADAFLAGS)" \
...@@ -477,18 +464,6 @@ common-tools: ../stamp-tools ...@@ -477,18 +464,6 @@ common-tools: ../stamp-tools
$(GNATLINK) -v gnatdll -o $@ \ $(GNATLINK) -v gnatdll -o $@ \
--GCC="$(CC) $(ADA_INCLUDES)" --LINK="$(GCC_LINK)" $(TOOLS_LIBS) --GCC="$(CC) $(ADA_INCLUDES)" --LINK="$(GCC_LINK)" $(TOOLS_LIBS)
../../vxaddr2line$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) vxaddr2line --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) vxaddr2line
$(GNATLINK) -v vxaddr2line -o $@ \
--GCC="$(CC) $(ADA_INCLUDES)" --LINK="$(GCC_LINK)" ../targext.o $(CLIB)
../../vxlink$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) vxlink-main --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) vxlink-main
$(GNATLINK) -v vxlink-main -o $@ \
--GCC="$(CC) $(ADA_INCLUDES)" --LINK="$(GCC_LINK)"
gnatmake-re: ../stamp-tools gnatmake-re: ../stamp-tools
$(GNATMAKE) -j0 $(ADA_INCLUDES) -u sdefault --GCC="$(CC) $(MOST_ADA_FLAGS)" $(GNATMAKE) -j0 $(ADA_INCLUDES) -u sdefault --GCC="$(CC) $(MOST_ADA_FLAGS)"
$(GNATMAKE) -j0 -c $(ADA_INCLUDES) gnatmake --GCC="$(CC) $(ALL_ADAFLAGS)" $(GNATMAKE) -j0 -c $(ADA_INCLUDES) gnatmake --GCC="$(CC) $(ALL_ADAFLAGS)"
......
gcc/ada/vxaddr2line.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- V X A D D R 2 L I N E --
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2018, AdaCore --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This program is meant to be used with vxworks to compute symbolic
-- backtraces on the host from non-symbolic backtraces obtained on the target.
-- The basic idea is to automate the computation of the necessary address
-- adjustments prior to calling addr2line when the application has only been
-- partially linked on the host.
-- Variants for various targets are supported, and the command line should
-- be like :
-- <target>-addr2line [-a <target_arch>] <exe_file> <ref_address>
-- <backtrace addresses>
-- Where:
-- <target_arch> :
-- selects the target architecture. In the absence of this parameter the
-- default variant is chosen based on the Detect_Arch result. Generally,
-- this parameter will only be used if vxaddr2line is recompiled manually.
-- Otherwise, the command name will always be of the form:
-- <target>-vxaddr2line
-- where there is no ambiguity on the target's architecture.
-- <exe_file> :
-- The name of the partially linked binary file for the application.
-- <ref_address> :
-- Runtime address (on the target) of a reference symbol you choose. This
-- name must match the value of the Ref_Symbol variable declared below.
-- A symbol with a small offset from the beginning of the text segment is
-- better, so "adainit" is a good choice.
-- <backtrace addresses> :
-- The call chain addresses you obtained at run time on the target and
-- for which you want a symbolic association.
-- TO ADD A NEW ARCHITECTURE add an appropriate value to Architecture type
-- (in a format <host>_<target>), and then an appropriate value to Config_List
-- array
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Interfaces; use Interfaces;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.Expect; use GNAT.Expect;
with GNAT.Regpat; use GNAT.Regpat;
procedure VxAddr2Line is
package Unsigned_64_IO is new Modular_IO (Unsigned_64);
-- Instantiate Modular_IO to have Put
Ref_Symbol : constant String := "adainit";
-- This is the name of the reference symbol whose runtime address must
-- be provided as the <ref_address> argument.
-- All supported architectures
type Architecture is
(LINUX_AARCH64,
LINUX_ARM,
LINUX_E500V2,
LINUX_I586,
LINUX_POWERPC,
LINUX_POWERPC64,
LINUX_X86_64,
WINDOWS_AARCH64,
WINDOWS_ARM,
WINDOWS_E500V2,
WINDOWS_I586,
WINDOWS_POWERPC,
WINDOWS_POWERPC64,
WINDOWS_X86_64);
type Arch_Record is record
Addr2line_Binary : String_Access;
-- Name of the addr2line utility to use
Nm_Binary : String_Access;
-- Name of the host nm utility, which will be used to find out the
-- offset of the reference symbol in the text segment of the partially
-- linked executable.
Addr_Digits_To_Skip : Integer;
-- When addresses such as 0xfffffc0001dfed50 are provided, for instance
-- on ALPHA, indicate the number of leading digits that can be ignored,
-- which will avoid computational overflows. Typically only useful when
-- 64bit addresses are provided.
Bt_Offset_From_Call : Unsigned_64;
-- Offset from a backtrace address to the address of the corresponding
-- call instruction. This should always be 0, except on platforms where
-- the backtrace addresses actually correspond to return and not call
-- points. In such cases, a negative value is most likely.
end record;
-- Configuration for each of the architectures
Arch_List : array (Architecture'Range) of Arch_Record :=
(LINUX_AARCH64 =>
(Addr2line_Binary => null,
Nm_Binary => null,
Addr_Digits_To_Skip => 0,
Bt_Offset_From_Call => -2),
LINUX_ARM =>
(Addr2line_Binary => null,
Nm_Binary => null,
Addr_Digits_To_Skip => 0,
Bt_Offset_From_Call => -2),
LINUX_E500V2 =>
(Addr2line_Binary => null,
Nm_Binary => null,
Addr_Digits_To_Skip => 0,
Bt_Offset_From_Call => -4),
LINUX_I586 =>
(Addr2line_Binary => null,
Nm_Binary => null,
Addr_Digits_To_Skip => 0,
Bt_Offset_From_Call => -2),
LINUX_POWERPC =>
(Addr2line_Binary => null,
Nm_Binary => null,
Addr_Digits_To_Skip => 0,
Bt_Offset_From_Call => -4),
LINUX_POWERPC64 =>
(Addr2line_Binary => null,
Nm_Binary => null,
Addr_Digits_To_Skip => 0,
Bt_Offset_From_Call => -4),
LINUX_X86_64 =>
(Addr2line_Binary => null,
Nm_Binary => null,
Addr_Digits_To_Skip => 0,
Bt_Offset_From_Call => -2),
WINDOWS_AARCH64 =>
(Addr2line_Binary => null,
Nm_Binary => null,
Addr_Digits_To_Skip => 0,
Bt_Offset_From_Call => -2),
WINDOWS_ARM =>
(Addr2line_Binary => null,
Nm_Binary => null,
Addr_Digits_To_Skip => 0,
Bt_Offset_From_Call => -2),
WINDOWS_E500V2 =>
(Addr2line_Binary => null,
Nm_Binary => null,
Addr_Digits_To_Skip => 0,
Bt_Offset_From_Call => -4),
WINDOWS_I586 =>
(Addr2line_Binary => null,
Nm_Binary => null,
Addr_Digits_To_Skip => 0,
Bt_Offset_From_Call => -2),
WINDOWS_POWERPC =>
(Addr2line_Binary => null,
Nm_Binary => null,
Addr_Digits_To_Skip => 0,
Bt_Offset_From_Call => -4),
WINDOWS_POWERPC64 =>
(Addr2line_Binary => null,
Nm_Binary => null,
Addr_Digits_To_Skip => 0,
Bt_Offset_From_Call => -4),
WINDOWS_X86_64 =>
(Addr2line_Binary => null,
Nm_Binary => null,
Addr_Digits_To_Skip => 0,
Bt_Offset_From_Call => -2)
);
-- Current architecture
Cur_Arch : Architecture;
-- State of architecture detection
Detect_Success : Boolean := False;
-----------------------
-- Local subprograms --
-----------------------
procedure Error (Msg : String);
pragma No_Return (Error);
-- Prints the message and then terminates the program
procedure Usage;
pragma No_Return (Usage);
-- Displays the short help message and then terminates the program
function Get_Reference_Offset return Unsigned_64;
-- Computes the static offset of the reference symbol by calling nm
function Get_Value_From_Hex_Arg (Arg : Natural) return Unsigned_64;
-- Threats the argument number Arg as a C-style hexadecimal literal
-- and returns its integer value
function Hex_Image (Value : Unsigned_64) return String_Access;
-- Returns access to a string that contains hexadecimal image of Value
-- Separate functions that provide build-time customization:
procedure Detect_Arch;
-- Saves in Cur_Arch the current architecture, based on the name of
-- vxaddr2line instance and properties of the host. Detect_Success is False
-- if detection fails
-----------------
-- Detect_Arch --
-----------------
procedure Detect_Arch is
Name : constant String := Base_Name (Command_Name);
Proc : constant String :=
Name (Name'First .. Index (Name, "-") - 1);
Target : constant String :=
Name (Name'First .. Index (Name, "vxaddr2line") - 1);
begin
Detect_Success := False;
if Proc = "" then
return;
end if;
-- Let's detect a Linux or Windows host.
if Directory_Separator = '/' then
Cur_Arch := Architecture'Value ("linux_" & Proc);
else
Cur_Arch := Architecture'Value ("windows_" & Proc);
end if;
if Arch_List (Cur_Arch).Addr2line_Binary = null then
Arch_List (Cur_Arch).Addr2line_Binary := new String'
(Target & "addr2line");
end if;
if Arch_List (Cur_Arch).Nm_Binary = null then
Arch_List (Cur_Arch).Nm_Binary := new String'
(Target & "nm");
end if;
Detect_Success := True;
exception
when others =>
return;
end Detect_Arch;
-----------
-- Error --
-----------
procedure Error (Msg : String) is
begin
Put_Line (Msg);
OS_Exit (1);
raise Program_Error;
end Error;
--------------------------
-- Get_Reference_Offset --
--------------------------
function Get_Reference_Offset return Unsigned_64 is
Nm_Cmd : constant String_Access :=
Locate_Exec_On_Path (Arch_List (Cur_Arch).Nm_Binary.all);
Nm_Args : constant Argument_List :=
(new String'("-P"),
new String'(Argument (1)));
Forever : aliased String := "^@@@@";
Reference : aliased String := Ref_Symbol & "\s+\S\s+([\da-fA-F]+)";
Pd : Process_Descriptor;
Result : Expect_Match;
begin
-- If Nm is not found, abort
if Nm_Cmd = null then
Error ("Couldn't find " & Arch_List (Cur_Arch).Nm_Binary.all);
end if;
Non_Blocking_Spawn
(Pd, Nm_Cmd.all, Nm_Args, Buffer_Size => 0, Err_To_Out => True);
-- Expect a string containing the reference symbol
Expect (Pd, Result,
Regexp_Array'(1 => Reference'Unchecked_Access),
Timeout => -1);
-- If we are here, the pattern was matched successfully
declare
Match_String : constant String := Expect_Out_Match (Pd);
Matches : Match_Array (0 .. 1);
Value : Unsigned_64 := 0;
begin
Match (Reference, Match_String, Matches);
Value := Unsigned_64'Value
("16#"
& Match_String (Matches (1).First .. Matches (1).Last) & "#");
-- Expect a string that will never be emitted, so that the
-- process can be correctly terminated (with Process_Died)
Expect (Pd, Result,
Regexp_Array'(1 => Forever'Unchecked_Access),
Timeout => -1);
exception
when Process_Died =>
return Value;
end;
-- We cannot get here
raise Program_Error;
exception
when Invalid_Process =>
Error ("Could not spawn a process " & Nm_Cmd.all);
when others =>
-- The process died without matching the reference symbol or the
-- format wasn't recognized.
Error ("Unexpected output from " & Nm_Cmd.all);
end Get_Reference_Offset;
----------------------------
-- Get_Value_From_Hex_Arg --
----------------------------
function Get_Value_From_Hex_Arg (Arg : Natural) return Unsigned_64 is
Cur_Arg : constant String := Argument (Arg);
Offset : Natural;
begin
-- Skip "0x" prefix if present
if Cur_Arg'Length > 2 and then Cur_Arg (1 .. 2) = "0x" then
Offset := 3;
else
Offset := 1;
end if;
-- Add architecture-specific offset
Offset := Offset + Arch_List (Cur_Arch).Addr_Digits_To_Skip;
-- Convert to value
return Unsigned_64'Value
("16#" & Cur_Arg (Offset .. Cur_Arg'Last) & "#");
exception
when Constraint_Error =>
Error ("Can't parse backtrace address '" & Cur_Arg & "'");
raise;
end Get_Value_From_Hex_Arg;
---------------
-- Hex_Image --
---------------
function Hex_Image (Value : Unsigned_64) return String_Access is
Result : String (1 .. 20);
Start_Pos : Natural;
begin
Unsigned_64_IO.Put (Result, Value, 16);
Start_Pos := Index (Result, "16#") + 3;
return new String'(Result (Start_Pos .. Result'Last - 1));
end Hex_Image;
-----------
-- Usage --
-----------
procedure Usage is
begin
Put_Line ("Usage : " & Base_Name (Command_Name)
& " <executable> <"
& Ref_Symbol & " offset on target> <addr1> ...");
OS_Exit (1);
end Usage;
Ref_Static_Offset, Ref_Runtime_Address, Bt_Address : Unsigned_64;
Addr2line_Cmd : String_Access;
Addr2line_Args : Argument_List (1 .. 501);
-- We expect that there won't be more than 500 backtrace frames
Addr2line_Args_Count : Natural;
Success : Boolean;
-- Start of processing for VxAddr2Line
begin
Detect_Arch;
-- There should be at least two arguments
if Argument_Count < 2 then
Usage;
end if;
-- Enforce HARD LIMIT There should be at most 501 arguments. Why 501???
if Argument_Count > 501 then
Error ("Too many backtrace frames");
end if;
-- Do we have a valid architecture?
if not Detect_Success then
Put_Line ("Couldn't detect the architecture");
return;
end if;
Addr2line_Cmd :=
Locate_Exec_On_Path (Arch_List (Cur_Arch).Addr2line_Binary.all);
-- If Addr2line is not found, abort
if Addr2line_Cmd = null then
Error ("Couldn't find " & Arch_List (Cur_Arch).Addr2line_Binary.all);
end if;
-- The first argument specifies the image file. Check if it exists
if not Is_Regular_File (Argument (1)) then
Error ("Couldn't find the executable " & Argument (1));
end if;
-- The second argument specifies the reference symbol runtime address.
-- Let's parse and store it
Ref_Runtime_Address := Get_Value_From_Hex_Arg (2);
-- Run nm command to get the reference symbol static offset
Ref_Static_Offset := Get_Reference_Offset;
-- Build addr2line parameters. First, the standard part
Addr2line_Args (1) := new String'("--exe=" & Argument (1));
Addr2line_Args_Count := 1;
-- Now, append to this the adjusted backtraces in arguments 4 and further
for J in 3 .. Argument_Count loop
-- Basically, for each address in the runtime backtrace ...
-- o We compute its offset relatively to the runtime address of the
-- reference symbol,
-- and then ...
-- o We add this offset to the static one for the reference symbol in
-- the executable to find the executable offset corresponding to the
-- backtrace address.
Bt_Address := Get_Value_From_Hex_Arg (J);
Bt_Address :=
Bt_Address - Ref_Runtime_Address
+ Ref_Static_Offset
+ Arch_List (Cur_Arch).Bt_Offset_From_Call;
Addr2line_Args_Count := Addr2line_Args_Count + 1;
Addr2line_Args (Addr2line_Args_Count) := Hex_Image (Bt_Address);
end loop;
-- Run the resulting command
Spawn (Addr2line_Cmd.all,
Addr2line_Args (1 .. Addr2line_Args_Count), Success);
if not Success then
Error ("Couldn't spawn " & Addr2line_Cmd.all);
end if;
exception
when others =>
-- Mask all exceptions
return;
end VxAddr2Line;
gcc/ada/vxlink-bind.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- V X L I N K . B I N D --
-- --
-- B o d y --
-- --
-- Copyright (C) 2018, AdaCore --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
pragma Ada_2012;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.IO_Exceptions;
with Ada.Strings.Fixed;
with GNAT.Regpat; use GNAT.Regpat;
package body VxLink.Bind is
function Split_Lines (S : String) return Strings_List.Vector;
function Split (S : String; C : Character) return Strings_List.Vector;
function Parse_Nm_Output (S : String) return Symbol_Sets.Set;
procedure Emit_Module_Dtor
(FP : File_Type);
procedure Emit_CDtor
(FP : File_Type;
Var : String;
Set : Symbol_Sets.Set);
-----------------
-- Split_Lines --
-----------------
function Split_Lines (S : String) return Strings_List.Vector
is
Last : Natural := S'First;
Ret : Strings_List.Vector;
begin
for J in S'Range loop
if S (J) = ASCII.CR
and then J < S'Last
and then S (J + 1) = ASCII.LF
then
Ret.Append (S (Last .. J - 1));
Last := J + 2;
elsif S (J) = ASCII.LF then
Ret.Append (S (Last .. J - 1));
Last := J + 1;
end if;
end loop;
if Last <= S'Last then
Ret.Append (S (Last .. S'Last));
end if;
return Ret;
end Split_Lines;
-----------
-- Split --
-----------
function Split (S : String; C : Character) return Strings_List.Vector
is
Last : Natural := S'First;
Ret : Strings_List.Vector;
begin
for J in S'Range loop
if S (J) = C then
if J > Last then
Ret.Append (S (Last .. J - 1));
end if;
Last := J + 1;
end if;
end loop;
if Last <= S'Last then
Ret.Append (S (Last .. S'Last));
end if;
return Ret;
end Split;
---------------------
-- Parse_Nm_Output --
---------------------
function Parse_Nm_Output (S : String) return Symbol_Sets.Set
is
Nm_Regexp : constant Pattern_Matcher :=
Compile ("^[0-9A-Za-z]* ([a-zA-Z]) (.*)$");
type CDTor_Type is
(CTOR_Diab,
CTOR_Gcc,
DTOR_Diab,
DTOR_Gcc);
subtype CTOR_Type is CDTor_Type range CTOR_Diab .. CTOR_Gcc;
CTOR_DIAB_Regexp : aliased constant Pattern_Matcher :=
Compile ("^__?STI__*([0-9]+)_");
CTOR_GCC_Regexp : aliased constant Pattern_Matcher :=
Compile ("^__?GLOBAL_.I._*([0-9]+)_");
DTOR_DIAB_Regexp : aliased constant Pattern_Matcher :=
Compile ("^__?STD__*([0-9]+)_");
DTOR_GCC_Regexp : aliased constant Pattern_Matcher :=
Compile ("^__?GLOBAL_.D._*([0-9]+)_");
type Regexp_Access is access constant Pattern_Matcher;
CDTor_Regexps : constant array (CDTor_Type) of Regexp_Access :=
(CTOR_Diab => CTOR_DIAB_Regexp'Access,
CTOR_Gcc => CTOR_GCC_Regexp'Access,
DTOR_Diab => DTOR_DIAB_Regexp'Access,
DTOR_Gcc => DTOR_GCC_Regexp'Access);
Result : Symbol_Sets.Set;
begin
for Line of Split_Lines (S) loop
declare
Sym : Symbol;
Nm_Grps : Match_Array (0 .. 2);
Ctor_Grps : Match_Array (0 .. 1);
begin
Match (Nm_Regexp, Line, Nm_Grps);
if Nm_Grps (0) /= No_Match then
declare
Sym_Type : constant Character :=
Line (Nm_Grps (1).First);
Sym_Name : constant String :=
Line (Nm_Grps (2).First .. Nm_Grps (2).Last);
begin
Sym :=
(Name => To_Unbounded_String (Sym_Name),
Cat => Sym_Type,
Internal => False,
Kind => Sym_Other,
Priority => -1);
for J in CDTor_Regexps'Range loop
Match (CDTor_Regexps (J).all, Sym_Name, Ctor_Grps);
if Ctor_Grps (0) /= No_Match then
if J in CTOR_Type then
Sym.Kind := Sym_Ctor;
else
Sym.Kind := Sym_Dtor;
end if;
Sym.Priority := Integer'Value
(Line (Ctor_Grps (1).First .. Ctor_Grps (1).Last));
exit;
end if;
end loop;
Result.Include (Sym);
end;
end if;
end;
end loop;
return Result;
end Parse_Nm_Output;
----------------
-- Initialize --
----------------
procedure Initialize
(Binder : out VxLink_Binder;
Object_File : String)
is
Args : Arguments_List;
Module_Dtor_Not_Needed : Boolean := False;
Module_Dtor_Needed : Boolean := False;
begin
Args.Append (Nm);
Args.Append (Object_File);
declare
Output : constant String := Run (Args);
Symbols : Symbol_Sets.Set;
begin
if Is_Error_State then
return;
end if;
Symbols := Parse_Nm_Output (Output);
for Sym of Symbols loop
if Sym.Kind = Sym_Ctor then
Binder.Constructors.Insert (Sym);
elsif Sym.Kind = Sym_Dtor then
Binder.Destructors.Insert (Sym);
elsif Match ("_?__.*_atexit$", To_String (Sym.Name)) then
if Sym.Cat = 'T' then
Module_Dtor_Not_Needed := True;
elsif Sym.Cat = 'U' then
Module_Dtor_Needed := True;
end if;
end if;
end loop;
Binder.Module_Dtor_Needed :=
not Module_Dtor_Not_Needed and then Module_Dtor_Needed;
end;
end Initialize;
--------------------
-- Parse_Tag_File --
--------------------
procedure Parse_Tag_File
(Binder : in out VxLink_Binder;
File : String)
is
FP : Ada.Text_IO.File_Type;
begin
Open
(FP,
Mode => In_File,
Name => File);
loop
declare
Line : constant String :=
Ada.Strings.Fixed.Trim
(Get_Line (FP), Ada.Strings.Both);
Tokens : Strings_List.Vector;
begin
if Line'Length = 0 then
-- Skip empty lines
null;
elsif Line (Line'First) = '#' then
-- Skip comment
null;
else
Tokens := Split (Line, ' ');
if Tokens.First_Element = "section" then
-- Sections are not used for tags, only when building
-- kernels. So skip for now
null;
else
Binder.Tags_List.Append (Line);
end if;
end if;
end;
end loop;
exception
when Ada.IO_Exceptions.End_Error =>
Close (FP);
when others =>
Log_Error ("Cannot open file " & File &
". DKM tags won't be generated");
end Parse_Tag_File;
----------------------
-- Emit_Module_Dtor --
----------------------
procedure Emit_Module_Dtor
(FP : File_Type)
is
Dtor_Name : constant String := "_GLOBAL__D_65536_0_cxa_finalize";
begin
Put_Line (FP, "extern void __cxa_finalize(void *);");
Put_Line (FP, "static void " & Dtor_Name & "()");
Put_Line (FP, "{");
Put_Line (FP, " __cxa_finalize(&__dso_handle);");
Put_Line (FP, "}");
Put_Line (FP, "");
end Emit_Module_Dtor;
----------------
-- Emit_CDtor --
----------------
procedure Emit_CDtor
(FP : File_Type;
Var : String;
Set : Symbol_Sets.Set)
is
begin
for Sym of Set loop
if not Sym.Internal then
Put_Line (FP, "extern void " & To_String (Sym.Name) & "();");
end if;
end loop;
New_Line (FP);
Put_Line (FP, "extern void (*" & Var & "[])();");
Put_Line (FP, "void (*" & Var & "[])() =");
Put_Line (FP, " {");
for Sym of Set loop
Put_Line (FP, " " & To_String (Sym.Name) & ",");
end loop;
Put_Line (FP, " 0};");
New_Line (FP);
end Emit_CDtor;
---------------
-- Emit_CTDT --
---------------
procedure Emit_CTDT
(Binder : in out VxLink_Binder;
Namespace : String)
is
FP : Ada.Text_IO.File_Type;
CDtor_File : constant String := Namespace & "-cdtor.c";
begin
Binder.CTDT_File := To_Unbounded_String (CDtor_File);
Create
(File => FP,
Name => CDtor_File);
Put_Line (FP, "#if defined(_HAVE_TOOL_XTORS)");
Put_Line (FP, "#include <vxWorks.h>");
if Binder.Module_Dtor_Needed then
Put_Line (FP, "#define _WRS_NEED_CALL_CXA_FINALIZE");
end if;
Put_Line (FP, "#include TOOL_HEADER (toolXtors.h)");
Put_Line (FP, "#else");
Put_Line (FP, "");
if Binder.Module_Dtor_Needed then
Emit_Module_Dtor (FP);
end if;
Emit_CDtor (FP, "_ctors", Binder.Constructors);
Emit_CDtor (FP, "_dtors", Binder.Destructors);
Put_Line (FP, "#endif");
if not Binder.Tags_List.Is_Empty then
New_Line (FP);
Put_Line (FP, "/* build variables */");
Put_Line (FP, "__asm("" .section \"".wrs_build_vars\"",\""a\"""");");
for Tag of Binder.Tags_List loop
Put_Line (FP, "__asm("" .ascii \""" & Tag & "\"""");");
Put_Line (FP, "__asm("" .byte 0"");");
end loop;
Put_Line (FP, "__asm("" .ascii \""end\"""");");
Put_Line (FP, "__asm("" .byte 0"");");
end if;
Close (FP);
exception
when others =>
Close (FP);
Set_Error_State ("Internal error");
raise;
end Emit_CTDT;
---------------
-- CTDT_File --
---------------
function CTDT_File (Binder : VxLink_Binder) return String
is
begin
return To_String (Binder.CTDT_File);
end CTDT_File;
end VxLink.Bind;
gcc/ada/vxlink-bind.ads deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- V X L I N K . B I N D --
-- --
-- S p e c --
-- --
-- Copyright (C) 2018, AdaCore --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
pragma Ada_2012;
private with Ada.Containers.Ordered_Sets;
private with Ada.Strings.Unbounded;
package VxLink.Bind is
type VxLink_Binder is private;
procedure Initialize
(Binder : out VxLink_Binder;
Object_File : String);
procedure Parse_Tag_File
(Binder : in out VxLink_Binder;
File : String);
procedure Emit_CTDT
(Binder : in out VxLink_Binder;
Namespace : String);
function CTDT_File (Binder : VxLink_Binder) return String;
private
use Ada.Strings.Unbounded;
type Symbol_Kind is (Sym_Ctor, Sym_Dtor, Sym_Other);
type Symbol is record
Name : Unbounded_String;
Cat : Character;
Internal : Boolean;
Kind : Symbol_Kind;
Priority : Integer;
end record;
function "=" (S1, S2 : Symbol) return Boolean
is (S1.Name = S2.Name and then S1.Cat = S2.Cat);
function "<" (S1, S2 : Symbol) return Boolean
is (if S1.Priority /= S2.Priority
then S1.Priority < S2.Priority
elsif S1.Name /= S2.Name
then S1.Name < S2.Name
else S1.Cat < S2.Cat);
package Symbol_Sets is new Ada.Containers.Ordered_Sets
(Symbol,
"<" => "<",
"=" => "=");
type VxLink_Binder is record
CTDT_File : Unbounded_String;
Constructors : Symbol_Sets.Set;
Destructors : Symbol_Sets.Set;
Module_Dtor_Needed : Boolean;
EH_Frame_Needed : Boolean;
Tags_List : Strings_List.Vector;
end record;
end VxLink.Bind;
gcc/ada/vxlink-link.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- V X L I N K . L I N K --
-- --
-- B o d y --
-- --
-- Copyright (C) 2018, AdaCore --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
pragma Ada_2012;
with Ada.Command_Line; use Ada.Command_Line;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
package body VxLink.Link is
Gcc : constant String := VxLink.Gcc;
----------------
-- Initialize --
----------------
procedure Initialize
(Linker : out VxLink_Linker)
is
Leading : Boolean := True;
Next_Is_Object : Boolean := False;
begin
for J in 1 .. Ada.Command_Line.Argument_Count loop
declare
Arg : String renames Argument (J);
begin
if Next_Is_Object then
Next_Is_Object := False;
Linker.Dest_Object := To_Unbounded_String (Arg);
Leading := False;
elsif Argument (J) = "-o" then
Next_Is_Object := True;
elsif Argument (J) = "-noauto-register" then
-- Filter out this argument, and do not generate _ctors/_dtors
Linker.Add_CDtors := False;
elsif Arg = "-v" and then not Is_Verbose then
-- first -v means VxLink should be verbose, two -v passes -v to
-- the linker.
Set_Verbose (True);
else
if Arg = "-nostdlib" or Arg = "-nostartfiles" then
Linker.Add_CDtors := False;
end if;
if Leading then
Linker.Args_Leading.Append (Arg);
else
Linker.Args_Trailing.Append (Arg);
end if;
end if;
end;
end loop;
if Linker.Dest_Object = Null_Unbounded_String then
Set_Error_State ("no output object is defined");
elsif Linker.Add_CDtors then
-- We'll need to create intermediate artefacts, so we'll use the
-- destination object as base namespace just in case we have
-- several link operations in the same directory
declare
Obj : constant String :=
Base_Name (To_String (Linker.Dest_Object));
begin
for J in reverse Obj'Range loop
if Obj (J) = '.' then
Linker.Dest_Base :=
To_Unbounded_String (Obj (Obj'First .. J - 1));
exit;
end if;
end loop;
Linker.Partial_Obj := Linker.Dest_Base & "-partial.o";
end;
end if;
end Initialize;
-----------------
-- Needs_CDtor --
-----------------
function Needs_CDtor (Linker : VxLink_Linker) return Boolean is
begin
return Linker.Add_CDtors;
end Needs_CDtor;
--------------------
-- Partial_Object --
--------------------
function Partial_Object (Linker : VxLink_Linker) return String is
begin
return To_String (Linker.Partial_Obj);
end Partial_Object;
---------------
-- Namespace --
---------------
function Namespace (Linker : VxLink_Linker) return String is
begin
return To_String (Linker.Dest_Base);
end Namespace;
---------------------
-- Do_Initial_Link --
---------------------
procedure Do_Initial_Link (Linker : VxLink_Linker)
is
Args : Arguments_List;
Gxx_Path : constant String := Gxx;
begin
if Is_Error_State then
return;
end if;
if Gxx_Path'Length /= 0 then
Args.Append (Gxx);
else
Args.Append (Gcc);
end if;
Args.Append (Linker.Args_Leading);
Args.Append ("-o");
if Linker.Add_CDtors then
Args.Append (To_String (Linker.Partial_Obj));
else
Args.Append (To_String (Linker.Dest_Object));
end if;
Args.Append (Linker.Args_Trailing);
if not Linker.Add_CDtors then
Args.Append ("-nostartfiles");
end if;
Run (Args);
end Do_Initial_Link;
-------------------
-- Do_Final_Link --
-------------------
procedure Do_Final_Link
(Linker : VxLink_Linker;
Ctdt_Obj : String)
is
Args : Arguments_List;
begin
if not Linker.Add_CDtors then
return;
end if;
if Is_Error_State then
return;
end if;
Args.Append (Gcc);
Args.Append ("-nostdlib");
Args.Append (Ctdt_Obj);
Args.Append (To_String (Linker.Partial_Obj));
Args.Append ("-o");
Args.Append (To_String (Linker.Dest_Object));
Run (Args);
end Do_Final_Link;
end VxLink.Link;
gcc/ada/vxlink-link.ads deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- V X L I N K . L I N K --
-- --
-- S p e c --
-- --
-- Copyright (C) 2018, AdaCore --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
pragma Ada_2012;
private with Ada.Strings.Unbounded;
package VxLink.Link is
type VxLink_Linker is private;
procedure Initialize
(Linker : out VxLink_Linker);
function Needs_CDtor (Linker : VxLink_Linker) return Boolean;
function Partial_Object (Linker : VxLink_Linker) return String;
function Namespace (Linker : VxLink_Linker) return String;
procedure Do_Initial_Link
(Linker : VxLink_Linker);
procedure Do_Final_Link
(Linker : VxLink_Linker;
Ctdt_Obj : String);
private
use Ada.Strings.Unbounded;
type VxLink_Linker is record
Args_Leading : Arguments_List;
Args_Trailing : Arguments_List;
Add_CDtors : Boolean := True;
Dest_Object : Unbounded_String;
Dest_Base : Unbounded_String;
Partial_Obj : Unbounded_String;
end record;
end VxLink.Link;
gcc/ada/vxlink-main.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- V X L I N K . M A I N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2018, AdaCore --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- VxLink is a helper tool used as a wrapper around g++/gcc to build VxWorks
-- DKM (Downloadable Kernel Modules).
-- Such DKM is a partially linked object that contains entry points for
-- constructors and destructors. This tool thus uses g++ to generate an
-- intermediate partially linked object, retrieves the list of constructors
-- and destructors in it and produces a C file that lists those ctors/dtors
-- in a way that is understood be VxWorks kernel. It then links this file
-- with the intermediate object to produce a valid DKM.
pragma Ada_2012;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with VxLink.Link; use VxLink.Link;
with VxLink.Bind; use VxLink.Bind;
procedure VxLink.Main is
Linker : VxLink_Linker;
Binder : VxLink_Binder;
VSB_Dir : String_Access := Getenv ("VSB_DIR");
begin
Initialize (Linker);
if Is_Error_State then
return;
end if;
Do_Initial_Link (Linker);
if Is_Error_State then
return;
end if;
if not Needs_CDtor (Linker) then
-- Initial link is enough, let's return
return;
end if;
if VSB_Dir /= null and then VSB_Dir'Length > 0 then
declare
DKM_Tag_File : constant String :=
Normalize_Pathname
("krnl/tags/dkm.tags", VSB_Dir.all);
begin
if Is_Regular_File (DKM_Tag_File) then
Parse_Tag_File (Binder, DKM_Tag_File);
end if;
end;
end if;
Initialize (Binder, Object_File => Partial_Object (Linker));
Emit_CTDT (Binder, Namespace => Namespace (Linker));
Do_Final_Link (Linker, CTDT_File (Binder));
Free (VSB_Dir);
end VxLink.Main;
gcc/ada/vxlink.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- V X L I N K --
-- --
-- B o d y --
-- --
-- Copyright (C) 2018, AdaCore --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
pragma Ada_2012;
with Ada.Command_Line;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_IO;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.Expect; use GNAT.Expect;
with GNAT.OS_Lib; use GNAT.OS_Lib;
package body VxLink is
Target_Triplet : Unbounded_String := Null_Unbounded_String;
Verbose : Boolean := False;
Error_State : Boolean := False;
function Triplet return String;
-- ??? missing spec
function Which (Exe : String) return String;
-- ??? missing spec
-------------
-- Triplet --
-------------
function Triplet return String is
begin
if Target_Triplet = Null_Unbounded_String then
declare
Exe : constant String := File_Name (Ada.Command_Line.Command_Name);
begin
for J in reverse Exe'Range loop
if Exe (J) = '-' then
Target_Triplet := To_Unbounded_String (Exe (Exe'First .. J));
exit;
end if;
end loop;
end;
end if;
return To_String (Target_Triplet);
end Triplet;
-----------
-- Which --
-----------
function Which (Exe : String) return String is
Suffix : GNAT.OS_Lib.String_Access := Get_Executable_Suffix;
Basename : constant String := Exe & Suffix.all;
Path : GNAT.OS_Lib.String_Access := Getenv ("PATH");
Last : Natural := Path'First;
begin
Free (Suffix);
for J in Path'Range loop
if Path (J) = Path_Separator then
declare
Full : constant String := Normalize_Pathname
(Name => Basename,
Directory => Path (Last .. J - 1),
Resolve_Links => False,
Case_Sensitive => True);
begin
if Is_Executable_File (Full) then
Free (Path);
return Full;
end if;
end;
Last := J + 1;
end if;
end loop;
Free (Path);
return "";
end Which;
-----------------
-- Set_Verbose --
-----------------
procedure Set_Verbose (Value : Boolean) is
begin
Verbose := Value;
end Set_Verbose;
----------------
-- Is_Verbose --
----------------
function Is_Verbose return Boolean is
begin
return Verbose;
end Is_Verbose;
---------------------
-- Set_Error_State --
---------------------
procedure Set_Error_State (Message : String) is
begin
Log_Error ("Error: " & Message);
Error_State := True;
Ada.Command_Line.Set_Exit_Status (1);
end Set_Error_State;
--------------------
-- Is_Error_State --
--------------------
function Is_Error_State return Boolean is
begin
return Error_State;
end Is_Error_State;
--------------
-- Log_Info --
--------------
procedure Log_Info (S : String) is
begin
if Verbose then
Ada.Text_IO.Put_Line (S);
end if;
end Log_Info;
---------------
-- Log_Error --
---------------
procedure Log_Error (S : String) is
begin
Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error, S);
end Log_Error;
---------
-- Run --
---------
procedure Run (Arguments : Arguments_List) is
Output : constant String := Run (Arguments);
begin
if not Is_Error_State then
-- In case of erroneous execution, the function version of run will
-- have already displayed the output
Ada.Text_IO.Put (Output);
end if;
end Run;
---------
-- Run --
---------
function Run (Arguments : Arguments_List) return String is
Args : GNAT.OS_Lib.Argument_List_Access :=
new GNAT.OS_Lib.Argument_List
(1 .. Natural (Arguments.Length) - 1);
Base : constant String := Base_Name (Arguments.First_Element);
Debug_Line : Unbounded_String;
Add_Quotes : Boolean;
begin
if Verbose then
Append (Debug_Line, Base);
end if;
for J in Arguments.First_Index + 1 .. Arguments.Last_Index loop
declare
Arg : String renames Arguments.Element (J);
begin
Args (J - 1) := new String'(Arg);
if Verbose then
Add_Quotes := False;
for K in Arg'Range loop
if Arg (K) = ' ' then
Add_Quotes := True;
exit;
end if;
end loop;
Append (Debug_Line, ' ');
if Add_Quotes then
Append (Debug_Line, '"' & Arg & '"');
else
Append (Debug_Line, Arg);
end if;
end if;
end;
end loop;
if Verbose then
Ada.Text_IO.Put_Line (To_String (Debug_Line));
end if;
declare
Status : aliased Integer := 0;
Ret : constant String :=
Get_Command_Output
(Command => Arguments.First_Element,
Arguments => Args.all,
Input => "",
Status => Status'Access,
Err_To_Out => True);
begin
GNAT.OS_Lib.Free (Args);
if Status /= 0 then
Ada.Text_IO.Put_Line (Ret);
Set_Error_State
(Base_Name (Arguments.First_Element) &
" returned" & Status'Image);
end if;
return Ret;
end;
end Run;
---------
-- Gcc --
---------
function Gcc return String is
begin
return Which (Triplet & "gcc");
end Gcc;
---------
-- Gxx --
---------
function Gxx return String is
begin
return Which (Triplet & "g++");
end Gxx;
--------
-- Nm --
--------
function Nm return String is
begin
return Which (Triplet & "nm");
end Nm;
end VxLink;
gcc/ada/vxlink.ads deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- V X L I N K --
-- --
-- S p e c --
-- --
-- Copyright (C) 2018, AdaCore --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- See vxlink-main.adb for a description of the tool.
--
-- This package contains only common utility functions used by the other
-- child packages.
pragma Ada_2012;
with Ada.Containers.Indefinite_Vectors;
package VxLink is
package Strings_List is new Ada.Containers.Indefinite_Vectors
(Positive, String);
subtype Arguments_List is Strings_List.Vector;
procedure Set_Verbose (Value : Boolean);
function Is_Verbose return Boolean;
procedure Set_Error_State (Message : String);
function Is_Error_State return Boolean;
procedure Log_Info (S : String);
procedure Log_Error (S : String);
procedure Run (Arguments : Arguments_List);
function Run (Arguments : Arguments_List) return String;
function Gcc return String;
-- Current toolchain's gcc command
function Gxx return String;
-- Current toolchain's g++ command
function Nm return String;
-- Current toolchain's nm command
function Ends_With (Str, Suffix : String) return Boolean
is (Str'Length >= Suffix'Length
and then Str (Str'Last - Suffix'Length + 1 .. Str'Last) = Suffix);
end VxLink;
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