-- GHDL driver - compile and link wrappers for VPI. -- Copyright (C) 2016 Tristan Gingold -- -- GHDL is free software; you can redistribute it and/or modify it under -- the terms of the GNU General Public License as published by the Free -- Software Foundation; either version 2, or (at your option) any later -- version. -- -- GHDL is distributed in the hope that it will be useful, but WITHOUT 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 -- along with GCC; see the file COPYING. If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with Ada.Text_IO; use Ada.Text_IO; with GNAT.OS_Lib; use GNAT.OS_Lib; with Ada.Command_Line; use Ada.Command_Line; with Ghdlmain; use Ghdlmain; with Ghdllocal; with Default_Paths; use Default_Paths; package body Ghdlvpi is -- Useful flags for target dependent operations. -- So, we only support unix, darwin and windows. Might need a little bit -- of tuning for another OS. Is_Unix : constant Boolean := Shared_Library_Extension = ".so"; Is_Darwin : constant Boolean := Shared_Library_Extension = ".dylib"; Is_Windows : constant Boolean := Shared_Library_Extension = ".dll"; -- Return the include directory. function Get_Vpi_Include_Dir return String is begin -- Compute install path Ghdllocal.Set_Exec_Prefix; return Ghdllocal.Exec_Prefix.all & Directory_Separator & "include"; end Get_Vpi_Include_Dir; -- Return the lib directory. function Get_Vpi_Lib_Dir return String is begin if Ghdllocal.Exec_Prefix = null then -- Compute install path (only once). Ghdllocal.Set_Exec_Prefix; end if; return Ghdllocal.Exec_Prefix.all & Directory_Separator & "lib"; end Get_Vpi_Lib_Dir; -- Return the lib directory, but unixify the path (for a unix shell in -- windows). function Get_Vpi_Lib_Dir_Unix return String is Res : String := Get_Vpi_Lib_Dir; begin if Is_Windows then -- Convert path separators. for I in Res'Range loop if Res (I) = '\' then Res (I) := '/'; end if; end loop; if Res'Length > 2 and then (Res (Res'First) in 'a' .. 'z' or else Res (Res'First) in 'A' .. 'Z') and then Res (Res'First + 1) = ':' then Res (Res'First + 1) := '/'; return '/' & Res; end if; end if; return Res; end Get_Vpi_Lib_Dir_Unix; function Get_Vpi_Cflags return Argument_List is Extra_Args : Argument_List (1 .. 2); Nbr : Natural; begin Extra_Args (1) := new String'("-I" & Get_Vpi_Include_Dir); Nbr := 1; if Is_Unix then -- PIC is the default on Darwin and Windows. Nbr := Nbr + 1; Extra_Args (Nbr) := new String'("-fPIC"); end if; return Extra_Args (1 .. Nbr); end Get_Vpi_Cflags; function Get_Vpi_Ldflags return Argument_List is Extra_Args : Argument_List (1 .. 4); Nbr : Natural; begin Extra_Args (1) := new String'("--shared"); Extra_Args (2) := new String'("-L" & Get_Vpi_Lib_Dir); Extra_Args (3) := new String'("-lghdlvpi"); Nbr := 3; if Is_Unix or Is_Darwin then -- On linux/unix, add rpath. -- No such concept on windows. Nbr := Nbr + 1; Extra_Args (Nbr) := new String' ("-Wl,-rpath," & Get_Vpi_Lib_Dir); end if; return Extra_Args (1 .. Nbr); end Get_Vpi_Ldflags; -- Display ARGS on a single line. procedure Disp (Args : Argument_List) is begin for I in Args'Range loop if I /= Args'First then Put (' '); end if; Put (Args (I).all); end loop; end Disp; procedure Spawn_Compile (User_Args : Argument_List; Extra_Args : Argument_List; Verbose : Boolean) is Cargs : Argument_List (1 .. User_Args'Length + Extra_Args'Length); Program_Name : String_Access; Nbr_Args : Natural; Status : Integer; begin Nbr_Args := 0; -- Extract compiler name. if User_Args'First > User_Args'Last then Error ("missing compiler name"); else Program_Name := User_Args (User_Args'First); if Ghdllocal.Is_Basename (Program_Name.all) then -- For a command name (without path component), search on the -- path. Program_Name := Locate_Exec_On_Path (Program_Name.all); else -- For a relative or absolute path, use the path directly. null; end if; end if; -- Copy user args. for I in User_Args'First + 1 .. User_Args'Last loop Nbr_Args := Nbr_Args + 1; Cargs (Nbr_Args) := User_Args (I); end loop; -- Copy extra args. for I in Extra_Args'Range loop Nbr_Args := Nbr_Args + 1; Cargs (Nbr_Args) := Extra_Args (I); end loop; -- Display command (if verbose) if Verbose then Put (Program_Name.all); for I in Cargs'First .. Nbr_Args loop Put (' '); Put (Cargs (I).all); end loop; New_Line; end if; -- Execute command Status := Spawn (Program_Name.all, Cargs (Cargs'First .. Nbr_Args)); Set_Exit_Status (Exit_Status (Status)); end Spawn_Compile; -- A command that accepts command and help strings. type Command_Str_Type is abstract new Command_Type with record Cmd_Str : String_Access; Help_Str : String_Access; end record; function Get_Short_Help (Cmd : Command_Str_Type) return String; function Decode_Command (Cmd : Command_Str_Type; Name : String) return Boolean is begin return Name = Cmd.Cmd_Str.all; end Decode_Command; function Get_Short_Help (Cmd : Command_Str_Type) return String is begin return Cmd.Help_Str.all; end Get_Short_Help; -- A command that spawn with extra_args type Extra_Args_Func is access function return Argument_List; type Command_Spawn_Type is new Command_Str_Type with record Flag_Verbose : Boolean := False; Extra_Args : Extra_Args_Func; end record; procedure Perform_Action (Cmd : Command_Spawn_Type; Args : Argument_List); procedure Decode_Option (Cmd : in out Command_Spawn_Type; Option : String; Arg : String; Res : out Option_Res); procedure Decode_Option (Cmd : in out Command_Spawn_Type; Option : String; Arg : String; Res : out Option_Res) is pragma Unreferenced (Arg); begin if Option = "-v" then Cmd.Flag_Verbose := True; Res := Option_Ok; else Res := Option_Bad; end if; end Decode_Option; procedure Perform_Action (Cmd : Command_Spawn_Type; Args : Argument_List) is begin Spawn_Compile (Args, Cmd.Extra_Args.all, Cmd.Flag_Verbose); end Perform_Action; -- A command that display flags. type Command_Vpi_Flags is new Command_Str_Type with record Flags : Extra_Args_Func; end record; procedure Perform_Action (Cmd : Command_Vpi_Flags; Args : Argument_List); procedure Perform_Action (Cmd : Command_Vpi_Flags; Args : Argument_List) is pragma Unreferenced (Args); begin Disp (Cmd.Flags.all); end Perform_Action; -- A command that display a string. type String_Func is access function return String; type Command_Vpi_Disp is new Command_Str_Type with record Disp : String_Func; end record; procedure Perform_Action (Cmd : Command_Vpi_Disp; Args : Argument_List); procedure Perform_Action (Cmd : Command_Vpi_Disp; Args : Argument_List) is pragma Unreferenced (Args); begin Put_Line (Cmd.Disp.all); end Perform_Action; procedure Register_Commands is begin Register_Command (new Command_Spawn_Type' (Command_Type with Flag_Verbose => False, Cmd_Str => new String' ("--vpi-compile"), Help_Str => new String' ("--vpi-compile CMD ARGS Compile with VPI include path"), Extra_Args => Get_Vpi_Cflags'Access)); Register_Command (new Command_Spawn_Type' (Command_Type with Flag_Verbose => False, Cmd_Str => new String' ("--vpi-link"), Help_Str => new String' ("--vpi-link CMD ARGS Link with VPI library"), Extra_Args => Get_Vpi_Ldflags'Access)); Register_Command (new Command_Vpi_Flags' (Command_Type with Cmd_Str => new String' ("--vpi-cflags"), Help_Str => new String' ("--vpi-cflags Display VPI compile flags"), Flags => Get_Vpi_Cflags'Access)); Register_Command (new Command_Vpi_Flags' (Command_Type with Cmd_Str => new String' ("--vpi-ldflags"), Help_Str => new String' ("--vpi-ldflags Display VPI link flags"), Flags => Get_Vpi_Ldflags'Access)); Register_Command (new Command_Vpi_Disp' (Command_Type with Cmd_Str => new String' ("--vpi-include-dir"), Help_Str => new String' ("--vpi-include-dir Display VPI include directory"), Disp => Get_Vpi_Include_Dir'Access)); Register_Command (new Command_Vpi_Disp' (Command_Type with Cmd_Str => new String' ("--vpi-library-dir"), Help_Str => new String' ("--vpi-library-dir Display VPI library directory"), Disp => Get_Vpi_Lib_Dir'Access)); Register_Command (new Command_Vpi_Disp' (Command_Type with Cmd_Str => new String' ("--vpi-library-dir-unix"), Help_Str => new String' ("--vpi-library-dir-unix " & "Display VPI library directory (unix form)"), Disp => Get_Vpi_Lib_Dir_Unix'Access)); end Register_Commands; end Ghdlvpi;