diff options
Diffstat (limited to 'translate/ghdldrv/ghdlmain.adb')
| -rw-r--r-- | translate/ghdldrv/ghdlmain.adb | 355 |
1 files changed, 355 insertions, 0 deletions
diff --git a/translate/ghdldrv/ghdlmain.adb b/translate/ghdldrv/ghdlmain.adb new file mode 100644 index 000000000..bd2462ff8 --- /dev/null +++ b/translate/ghdldrv/ghdlmain.adb @@ -0,0 +1,355 @@ +-- GHDL driver - main part. +-- Copyright (C) 2002, 2003, 2004, 2005 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; +with Ada.Command_Line; +with Version; +with Flags; +with Bug; +with Errorout; + +package body Ghdlmain is + procedure Init (Cmd : in out Command_Type) + is + pragma Unreferenced (Cmd); + begin + null; + end Init; + + procedure Decode_Option (Cmd : in out Command_Type; + Option : String; + Arg : String; + Res : out Option_Res) + is + pragma Unreferenced (Cmd); + pragma Unreferenced (Option); + pragma Unreferenced (Arg); + begin + Res := Option_Bad; + end Decode_Option; + + procedure Disp_Long_Help (Cmd : Command_Type) + is + pragma Unreferenced (Cmd); + use Ada.Text_IO; + begin + Put_Line ("This command does not accept options."); + end Disp_Long_Help; + + First_Cmd : Command_Acc := null; + Last_Cmd : Command_Acc := null; + + procedure Register_Command (Cmd : Command_Acc) is + begin + if First_Cmd = null then + First_Cmd := Cmd; + else + Last_Cmd.Next := Cmd; + end if; + Last_Cmd := Cmd; + end Register_Command; + + -- Find the command. + function Find_Command (Action : String) return Command_Acc + is + Cmd : Command_Acc; + begin + Cmd := First_Cmd; + while Cmd /= null loop + if Decode_Command (Cmd.all, Action) then + return Cmd; + end if; + Cmd := Cmd.Next; + end loop; + return null; + end Find_Command; + + -- Command help. + type Command_Help is new Command_Type with null record; + function Decode_Command (Cmd : Command_Help; Name : String) return Boolean; + procedure Decode_Option (Cmd : in out Command_Help; + Option : String; + Arg : String; + Res : out Option_Res); + + function Get_Short_Help (Cmd : Command_Help) return String; + procedure Perform_Action (Cmd : in out Command_Help; Args : Argument_List); + + function Decode_Command (Cmd : Command_Help; Name : String) return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-h" or else Name = "--help"; + end Decode_Command; + + procedure Decode_Option (Cmd : in out Command_Help; + Option : String; + Arg : String; + Res : out Option_Res) + is + pragma Unreferenced (Cmd); + pragma Unreferenced (Option); + pragma Unreferenced (Arg); + begin + Res := Option_End; + end Decode_Option; + + function Get_Short_Help (Cmd : Command_Help) return String + is + pragma Unreferenced (Cmd); + begin + return "-h or --help [CMD] Disp this help or [help on CMD]"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Help; Args : Argument_List) + is + pragma Unreferenced (Cmd); + + use Ada.Text_IO; + use Ada.Command_Line; + C : Command_Acc; + begin + if Args'Length = 0 then + Put_Line ("usage: " & Command_Name & " COMMAND [OPTIONS] ..."); + Put_Line ("COMMAND is one of:"); + C := First_Cmd; + while C /= null loop + Put_Line (Get_Short_Help (C.all)); + C := C.Next; + end loop; + New_Line; + Put_Line + ("To display the options of a GHDL program, run your program"); + Put_Line (" with the --help option."); + Put_Line ("Please, refer to the GHDL manual for more information."); + Put_Line ("Report bugs to <ghdl@free.fr>."); + elsif Args'Length = 1 then + C := Find_Command (Args (1).all); + if C = null then + Error ("Command '" & Args (1).all & "' is unknown."); + raise Option_Error; + end if; + Put_Line (Get_Short_Help (C.all)); + Disp_Long_Help (C.all); + else + Error ("Command '--help' accepts at most one argument."); + raise Option_Error; + end if; + end Perform_Action; + + -- Command options help. + type Command_Option_Help is new Command_Type with null record; + function Decode_Command (Cmd : Command_Option_Help; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Option_Help) return String; + procedure Perform_Action (Cmd : in out Command_Option_Help; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Option_Help; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "--options-help"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Option_Help) return String + is + pragma Unreferenced (Cmd); + begin + return "--options-help Disp help for compiler options"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Option_Help; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + begin + if Args'Length /= 0 then + Error + ("warning: command '--option-help' does not accept any argument"); + end if; + Flags.Disp_Options_Help; + end Perform_Action; + + -- Command Version + type Command_Version is new Command_Type with null record; + function Decode_Command (Cmd : Command_Version; Name : String) + return Boolean; + function Get_Short_Help (Cmd : Command_Version) return String; + procedure Perform_Action (Cmd : in out Command_Version; + Args : Argument_List); + + function Decode_Command (Cmd : Command_Version; Name : String) + return Boolean + is + pragma Unreferenced (Cmd); + begin + return Name = "-v" or Name = "--version"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_Version) return String + is + pragma Unreferenced (Cmd); + begin + return "-v or --version Disp ghdl version"; + end Get_Short_Help; + + procedure Perform_Action (Cmd : in out Command_Version; + Args : Argument_List) + is + pragma Unreferenced (Cmd); + use Ada.Text_IO; + begin + Put_Line (Version.Ghdl_Version); + if Version_String /= null then + Put_Line (Version_String.all); + end if; + Put_Line ("Written by Tristan Gingold."); + New_Line; + Put_Line ("Copyright (C) 2003, 2004, 2005 Tristan Gingold."); + Put_Line ("This is free software; see the source for copying conditions." + & " There is NO"); + Put_Line ("warranty; not even for MERCHANTABILITY or FITNESS FOR A " + & "PARTICULAR PURPOSE."); + if Args'Length /= 0 then + Error ("warning: command '--version' does not accept any argument"); + end if; + end Perform_Action; + + -- Disp MSG on the standard output with the command name. + procedure Error (Msg : String) + is + use Ada.Command_Line; + use Ada.Text_IO; + begin + Put (Standard_Error, Command_Name); + Put (Standard_Error, ": "); + Put_Line (Standard_Error, Msg); + --Has_Error := True; + end Error; + + procedure Main + is + use Ada.Command_Line; + Cmd : Command_Acc; + Arg_Index : Natural; + First_Arg : Natural; + + begin + if Argument_Count = 0 then + Error ("missing command, try " & Command_Name & " --help"); + raise Option_Error; + end if; + + Cmd := Find_Command (Argument (1)); + if Cmd = null then + Error ("unknown command '" & Argument (1) & "', try --help"); + raise Option_Error; + end if; + + Init (Cmd.all); + + -- decode options. + + First_Arg := 0; + Arg_Index := 2; + while Arg_Index <= Argument_Count loop + declare + Arg : String := Argument (Arg_Index); + Res : Option_Res; + begin + if Arg (1) = '-' then + -- Argument is an option. + + if First_Arg > 0 then + Error ("options after file"); + raise Option_Error; + end if; + + Decode_Option (Cmd.all, Arg, "", Res); + case Res is + when Option_Bad => + Error ("unknown option '" & Arg & "' for command '" + & Argument (1) & "'"); + raise Option_Error; + when Option_Ok => + Arg_Index := Arg_Index + 1; + when Option_Arg_Req => + if Arg_Index + 1 > Argument_Count then + Error ("option '" & Arg & "' requires an argument"); + raise Option_Error; + end if; + Decode_Option + (Cmd.all, Arg, Argument (Arg_Index + 1), Res); + if Res /= Option_Arg then + raise Program_Error; + end if; + Arg_Index := Arg_Index + 2; + when Option_Arg => + raise Program_Error; + when Option_End => + First_Arg := Arg_Index; + exit; + end case; + else + First_Arg := Arg_Index; + exit; + end if; + end; + end loop; + + if First_Arg = 0 then + First_Arg := Argument_Count + 1; + end if; + + declare + Args : Argument_List (1 .. Argument_Count - First_Arg + 1); + begin + for I in Args'Range loop + Args (I) := new String'(Argument (First_Arg + I - 1)); + end loop; + Perform_Action (Cmd.all, Args); + for I in Args'Range loop + Free (Args (I)); + end loop; + end; + --if Flags.Dump_Stats then + -- Name_Table.Disp_Stats; + -- Iirs.Disp_Stats; + --end if; + Set_Exit_Status (Success); + exception + when Option_Error + | Compile_Error + | Errorout.Compilation_Error => + Set_Exit_Status (Failure); + when Exec_Error => + Set_Exit_Status (3); + when E: others => + Bug.Disp_Bug_Box (E); + Set_Exit_Status (2); + end Main; + + procedure Register_Commands is + begin + Register_Command (new Command_Help); + Register_Command (new Command_Option_Help); + Register_Command (new Command_Version); + end Register_Commands; +end Ghdlmain; + |