+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>
* exp_aggr.adb, exp_ch7.adb, gnat1drv.adb, sem_ch10.adb,
cross-gnattools: force
$(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) gnattools4
canadian-gnattools: force
$(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) gnattools4
gnatlib gnatlib-sjlj gnatlib-zcx gnatlib-shared: force
$(MAKE) -C ada $(COMMON_FLAGS_TO_PASS) \
# gnatlink, gnatls, gnatmake, gnatname, gnatprep, gnatxref, gnatfind,
# gnatclean).
# gnatdll is only used on Windows.
-# vxaddr2line is only used for cross VxWorks ports (it calls the underlying
-# cross addr2line).
ada.install-common:
$(MKDIR) $(DESTDIR)$(bindir)
-if [ -f gnat1$(exeext) ] ; \
done; \
$(RM) $(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
#
-$(RM) $(DESTDIR)$(bindir)/$$install_name; \
done
-$(RM) $(DESTDIR)$(tooldir)/bin/gnatdll$(exeext)
- -$(RM) $(DESTDIR)$(tooldir)/bin/vxaddr2line$(exeext)
# Clean hooks:
# A lot of the ancillary files are deleted by the main makefile.
$(MAKE) -C tools -f ../Makefile $(TOOLS_FLAGS_TO_PASS) \
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
$(GNATMAKE) -j0 -c -b $(ADA_INCLUDES) \
--GNATBIND="$(GNATBIND)" --GCC="$(CC) $(ALL_ADAFLAGS)" \
$(GNATLINK) -v gnatdll -o $@ \
--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) -j0 $(ADA_INCLUDES) -u sdefault --GCC="$(CC) $(MOST_ADA_FLAGS)"
$(GNATMAKE) -j0 -c $(ADA_INCLUDES) gnatmake --GCC="$(CC) $(ALL_ADAFLAGS)"
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
projects / gcc.git / commitdiff