+2018-08-21 Jerome Lambourg <lambourg@adacore.com>
+
+ * vxlink-bind.adb, vxlink-bind.ads, vxlink-link.adb,
+ vxlink-link.ads, vxlink-main.adb, vxlink.adb, vxlink.ads: Add a
+ new tool vxlink to handle VxWorks constructors in DKMs.
+ * gcc-interface/Makefile.in: add rules to build vxlink
+
2018-08-21 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Analyze_Subprogram_Body_Helper, Mask_Type):
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) \
$(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 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;
+
+ function Which (Exe : String) return String;
+
+ -------------
+ -- 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);
+ Status : aliased Integer := 0;
+ 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
+ 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