From cd012609781465b65bbe3b1ef8e1fe4fa9c8398d Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Mon, 24 Jun 2019 22:07:30 +0200 Subject: Error_Msg_Option: do not raise exception. --- src/errorout.adb | 8 +--- src/errorout.ads | 9 +--- src/ghdldrv/ghdlcomp.adb | 22 ++++++---- src/ghdldrv/ghdldrv.adb | 89 ++++++++++++++++++++------------------ src/ghdldrv/ghdllocal.adb | 35 ++++++--------- src/ghdldrv/ghdllocal.ads | 5 ++- src/ghdldrv/ghdlmain.adb | 22 ++++------ src/ghdldrv/ghdlmain.ads | 17 +------- src/ghdldrv/ghdlprint.adb | 14 +++--- src/ghdldrv/ghdlsynth.adb | 5 ++- src/ghdldrv/ghdlvpi.adb | 7 +-- src/libraries.adb | 4 +- src/options.adb | 42 ++++++++++-------- src/options.ads | 26 ++++++++++- src/vhdl/libghdl/libghdl.adb | 3 +- src/vhdl/translate/ortho_front.adb | 12 ++--- src/vhdl/vhdl-scanner.adb | 10 ++++- src/vhdl/vhdl-scanner.ads | 4 +- 18 files changed, 177 insertions(+), 157 deletions(-) (limited to 'src') diff --git a/src/errorout.adb b/src/errorout.adb index 5e706c475..485f5fef3 100644 --- a/src/errorout.adb +++ b/src/errorout.adb @@ -388,15 +388,9 @@ package body Errorout is Report_Handler.Message_Group.all (False); end Report_End_Group; - procedure Error_Msg_Option_NR (Msg: String) is + procedure Error_Msg_Option (Msg: String) is begin Report_Msg (Msgid_Error, Option, No_Source_Coord, Msg); - end Error_Msg_Option_NR; - - procedure Error_Msg_Option (Msg: String; Args : Earg_Arr := No_Eargs) is - begin - Report_Msg (Msgid_Error, Option, No_Source_Coord, Msg, Args); - raise Option_Error; end Error_Msg_Option; procedure Warning_Msg_Option (Id : Msgid_Warnings; Msg: String) is diff --git a/src/errorout.ads b/src/errorout.ads index 860e663ba..580d09e44 100644 --- a/src/errorout.ads +++ b/src/errorout.ads @@ -20,7 +20,6 @@ with Vhdl.Nodes; with Vhdl.Tokens; package Errorout is - Option_Error: exception; Compilation_Error: exception; -- The number of errors (ie, number of calls to error_msg*). @@ -223,14 +222,10 @@ package Errorout is procedure Report_Start_Group; procedure Report_End_Group; - -- Disp an error, prepended with program name, and raise option_error. + -- Disp an error, prepended with program name. -- This is used for errors before initialisation, such as bad option or -- bad filename. - procedure Error_Msg_Option (Msg: String; Args : Earg_Arr := No_Eargs); - pragma No_Return (Error_Msg_Option); - - -- Same as Error_Msg_Option but do not raise Option_Error. - procedure Error_Msg_Option_NR (Msg: String); + procedure Error_Msg_Option (Msg: String); -- Warn about an option. procedure Warning_Msg_Option (Id : Msgid_Warnings; Msg: String); diff --git a/src/ghdldrv/ghdlcomp.adb b/src/ghdldrv/ghdlcomp.adb index 619d1afb0..0282736d5 100644 --- a/src/ghdldrv/ghdlcomp.adb +++ b/src/ghdldrv/ghdlcomp.adb @@ -17,6 +17,7 @@ -- 02111-1307, USA. with Ghdlmain; use Ghdlmain; with Ghdllocal; use Ghdllocal; +with Options; use Options; with Ada.Command_Line; @@ -42,13 +43,13 @@ package body Ghdlcomp is procedure Decode_Option (Cmd : in out Command_Comp; Option : String; Arg : String; - Res : out Option_Res); + Res : out Option_State); procedure Disp_Long_Help (Cmd : Command_Comp); procedure Decode_Option (Cmd : in out Command_Comp; Option : String; Arg : String; - Res : out Option_Res) + Res : out Option_State) is pragma Assert (Option'First = 1); begin @@ -159,7 +160,7 @@ package body Ghdlcomp is procedure Decode_Option (Cmd : in out Command_Compile; Option : String; Arg : String; - Res : out Option_Res); + Res : out Option_State); procedure Perform_Action (Cmd : Command_Compile; Args : Argument_List); @@ -182,7 +183,7 @@ package body Ghdlcomp is procedure Decode_Option (Cmd : in out Command_Compile; Option : String; Arg : String; - Res : out Option_Res) + Res : out Option_State) is begin if Option = "-r" or else Option = "-e" then @@ -348,6 +349,7 @@ package body Ghdlcomp is else if Run_Arg <= Args'Last then Error_Msg_Option ("options after unit are ignored"); + raise Option_Error; end if; end if; end Perform_Action; @@ -492,7 +494,7 @@ package body Ghdlcomp is procedure Decode_Option (Cmd : in out Command_Elab; Option : String; Arg : String; - Res : out Option_Res); + Res : out Option_State); procedure Perform_Action (Cmd : Command_Elab; Args : Argument_List); @@ -515,7 +517,7 @@ package body Ghdlcomp is procedure Decode_Option (Cmd : in out Command_Elab; Option : String; Arg : String; - Res : out Option_Res) + Res : out Option_State) is pragma Assert (Option'First = 1); begin @@ -529,10 +531,11 @@ package body Ghdlcomp is -- Silently accepted. Res := Option_Arg; end if; - elsif Option'Length >= 4 - and then Option (1 .. 4) = "-Wl," then + elsif Option'Length >= 4 and then Option (1 .. 4) = "-Wl," + then Error_Msg_Option ("option -Wl is not available when ghdl " & "is not configured with gcc or llvm"); + Res := Option_Err; else Decode_Option (Command_Lib (Cmd), Option, Arg, Res); end if; @@ -553,6 +556,7 @@ package body Ghdlcomp is Hooks.Compile_Elab.all ("-e", Args, Run_Arg); if Run_Arg <= Args'Last then Error_Msg_Option ("options after unit are ignored"); + raise Option_Error; end if; if Flag_Expect_Failure then raise Compilation_Error; @@ -611,7 +615,7 @@ package body Ghdlcomp is begin if Args'Length /= 0 then Error ("--disp-config does not accept any argument"); - raise Errorout.Option_Error; + raise Option_Error; end if; Put_Line ("command_name: " & Ada.Command_Line.Command_Name); diff --git a/src/ghdldrv/ghdldrv.adb b/src/ghdldrv/ghdldrv.adb index 5817b974d..463b3e9c6 100644 --- a/src/ghdldrv/ghdldrv.adb +++ b/src/ghdldrv/ghdldrv.adb @@ -15,27 +15,27 @@ -- 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 System; with Ada.Command_Line; use Ada.Command_Line; +with Interfaces.C_Streams; with GNAT.OS_Lib; use GNAT.OS_Lib; +with Types; use Types; with Tables; with Dyn_Tables; -with Simple_IO; use Simple_IO; +with Files_Map; with Libraries; +with Default_Paths; +with Simple_IO; use Simple_IO; with Name_Table; use Name_Table; with Vhdl.Std_Package; -with Types; use Types; with Vhdl.Nodes; use Vhdl.Nodes; -with Files_Map; with Vhdl.Configuration; -with Default_Paths; -with Interfaces.C_Streams; -with System; +with Options; use Options; with Ghdlmain; use Ghdlmain; with Ghdllocal; use Ghdllocal; with Errorout; with Version; -with Options; package body Ghdldrv is -- Name of the tools used. @@ -577,7 +577,7 @@ package body Ghdldrv is procedure Decode_Option (Cmd : in out Command_Comp; Option : String; Arg : String; - Res : out Option_Res); + Res : out Option_State); procedure Disp_Long_Help (Cmd : Command_Comp); @@ -602,12 +602,12 @@ package body Ghdldrv is procedure Decode_Option (Cmd : in out Command_Comp; Option : String; Arg : String; - Res : out Option_Res) + Res : out Option_State) is Opt : constant String (1 .. Option'Length) := Option; Str : String_Access; begin - Res := Option_Bad; + Res := Option_Unknown; if Opt = "-v" and then Flag_Verbose = False then -- Note: this is also decoded for command_lib, but we set -- Flag_Disp_Commands too. @@ -655,7 +655,8 @@ package body Ghdldrv is Add_Arguments (Linker_Args, Opt); else Error ("unknown tool name in '-W" & Opt (3) & ",' option"); - raise Option_Error; + Res := Option_Err; + return; end if; Res := Option_Ok; elsif Opt'Length >= 2 and then Opt (2) = 'g' then @@ -682,37 +683,42 @@ package body Ghdldrv is elsif Opt = "--dyn-elab" then Elab_Mode := Elab_Dynamic; Res := Option_Ok; - elsif Options.Parse_Option (Opt) then - if Opt'Length > 2 and then Opt (1 .. 2) = "-P" then - -- Discard -Pxxx switches, as they are already added to - -- compiler_args. - null; - else - if Backend = Backend_Gcc then - -- Prefix options for gcc so that lang.opt does need to be - -- updated when a new option is added. - Str := new String'("--ghdl" & Opt); - else - Str := new String'(Opt); - end if; - Add_Argument (Compiler_Args, Str); - end if; - Res := Option_Ok; elsif Opt'Length > 18 and then Opt (1 .. 18) = "--time-resolution=" then Error ("option --time-resolution not supported by back-end"); - raise Option_Error; - elsif Opt'Length >= 2 - and then (Opt (2) = 'O' or Opt (2) = 'f') - then - -- Optimization option. - -- This is put after Flags.Parse_Option, since it may catch -fxxx - -- options. - Add_Argument (Compiler_Args, new String'(Opt)); - Res := Option_Ok; + Res := Option_Err; + return; else - Decode_Option (Command_Lib (Cmd), Opt, Arg, Res); + Res := Options.Parse_Option (Opt); + if Res = Option_Ok then + if Opt'Length > 2 and then Opt (1 .. 2) = "-P" then + -- Discard -Pxxx switches, as they are already added to + -- compiler_args. + null; + else + if Backend = Backend_Gcc then + -- Prefix options for gcc so that lang.opt does need to be + -- updated when a new option is added. + Str := new String'("--ghdl" & Opt); + else + Str := new String'(Opt); + end if; + Add_Argument (Compiler_Args, Str); + end if; + elsif Res = Option_Unknown then + if Opt'Length >= 2 + and then (Opt (2) = 'O' or Opt (2) = 'f') + then + -- Optimization option supported by gcc/llvm. + -- This is put after Flags.Parse_Option, since it may catch + -- -fxxx options. + Add_Argument (Compiler_Args, new String'(Opt)); + Res := Option_Ok; + else + Decode_Option (Command_Lib (Cmd), Opt, Arg, Res); + end if; + end if; end if; end Decode_Option; @@ -1316,7 +1322,7 @@ package body Ghdldrv is procedure Decode_Option (Cmd : in out Command_Anaelab; Option : String; Arg : String; - Res : out Option_Res); + Res : out Option_State); procedure Perform_Action (Cmd : Command_Anaelab; Args : Argument_List); @@ -1340,8 +1346,7 @@ package body Ghdldrv is procedure Decode_Option (Cmd : in out Command_Anaelab; Option : String; Arg : String; - Res : out Option_Res) - is + Res : out Option_State) is begin if Option = "-e" then Res := Option_End; @@ -1397,7 +1402,7 @@ package body Ghdldrv is procedure Decode_Option (Cmd : in out Command_Make; Option : String; Arg : String; - Res : out Option_Res); + Res : out Option_State); function Get_Short_Help (Cmd : Command_Make) return String; procedure Disp_Long_Help (Cmd : Command_Make); @@ -1440,7 +1445,7 @@ package body Ghdldrv is procedure Decode_Option (Cmd : in out Command_Make; Option : String; Arg : String; - Res : out Option_Res) is + Res : out Option_State) is begin if Option = "-b" then Cmd.Flag_Bind_Only := True; diff --git a/src/ghdldrv/ghdllocal.adb b/src/ghdldrv/ghdllocal.adb index d7db3965f..fa2525112 100644 --- a/src/ghdldrv/ghdllocal.adb +++ b/src/ghdldrv/ghdllocal.adb @@ -33,7 +33,6 @@ with Vhdl.Scanner; with Errorout; with Vhdl.Configuration; with Files_Map; -with Options; with Vhdl.Utils; use Vhdl.Utils; package body Ghdllocal is @@ -58,54 +57,44 @@ package body Ghdllocal is Compile_Init; end Init; - function Decode_Driver_Option (Opt : String) return Boolean + function Decode_Driver_Option (Opt : String) return Option_State is pragma Assert (Opt'First = 1); begin if Opt = "-v" and then Flag_Verbose = False then Flag_Verbose := True; - return True; elsif Opt'Length > 9 and then Opt (1 .. 9) = "--PREFIX=" then Switch_Prefix_Path := new String'(Opt (10 .. Opt'Last)); - return True; elsif Opt = "--ieee=synopsys" then Flag_Ieee := Lib_Synopsys; - return True; elsif Opt = "--ieee=mentor" then Flag_Ieee := Lib_Mentor; - return True; elsif Opt = "--ieee=none" then Flag_Ieee := Lib_None; - return True; elsif Opt = "--ieee=standard" then Flag_Ieee := Lib_Standard; - return True; elsif Opt = "-m32" then Flag_32bit := True; - return True; elsif Opt'Length >= 2 and then (Opt (2) = 'g' or Opt (2) = 'O') then -- Silently accept -g and -O. - return True; + null; else return Options.Parse_Option (Opt); end if; + return Option_Ok; end Decode_Driver_Option; procedure Decode_Option (Cmd : in out Command_Lib; Option : String; Arg : String; - Res : out Option_Res) + Res : out Option_State) is pragma Unreferenced (Cmd); pragma Unreferenced (Arg); begin - if Decode_Driver_Option (Option) then - Res := Option_Ok; - else - Res := Option_Bad; - end if; + Res := Decode_Driver_Option (Option); end Decode_Option; procedure Disp_Long_Help (Cmd : Command_Lib) @@ -761,7 +750,7 @@ package body Ghdllocal is procedure Decode_Option (Cmd : in out Command_Check_Syntax; Option : String; Arg : String; - Res : out Option_Res); + Res : out Option_State); function Get_Short_Help (Cmd : Command_Check_Syntax) return String; procedure Perform_Action (Cmd : Command_Check_Syntax; Args : Argument_List); @@ -784,7 +773,7 @@ package body Ghdllocal is procedure Decode_Option (Cmd : in out Command_Check_Syntax; Option : String; Arg : String; - Res : out Option_Res) + Res : out Option_State) is pragma Assert (Option'First = 1); begin @@ -1610,19 +1599,23 @@ package body Ghdllocal is end Is_A_File_Name; Res : String_Access; + Err : Boolean; begin -- Try to identifier bad names (such as file names), so that -- friendly message can be displayed. if Is_Bad_Unit_Name then - Errorout.Error_Msg_Option_NR ("bad unit name '" & Name.all & "'"); + Errorout.Error_Msg_Option ("bad unit name '" & Name.all & "'"); if Is_A_File_Name then - Errorout.Error_Msg_Option_NR + Errorout.Error_Msg_Option ("(a unit name is required instead of a filename)"); end if; raise Option_Error; end if; Res := new String'(Name.all); - Vhdl.Scanner.Convert_Identifier (Res.all); + Vhdl.Scanner.Convert_Identifier (Res.all, Err); + if Err then + raise Option_Error; + end if; return Res; end Convert_Name; diff --git a/src/ghdldrv/ghdllocal.ads b/src/ghdldrv/ghdllocal.ads index 0a903a129..553ebfda0 100644 --- a/src/ghdldrv/ghdllocal.ads +++ b/src/ghdldrv/ghdllocal.ads @@ -18,6 +18,7 @@ with GNAT.OS_Lib; use GNAT.OS_Lib; with Ghdlmain; use Ghdlmain; with Vhdl.Nodes; use Vhdl.Nodes; +with Options; use Options; package Ghdllocal is -- Init procedure for the functionnal interface. @@ -25,7 +26,7 @@ package Ghdllocal is -- Handle: -- --std=xx, --work=xx, -Pxxx, --workdir=x, --ieee=x, -Px, and -v - function Decode_Driver_Option (Opt : String) return Boolean; + function Decode_Driver_Option (Opt : String) return Option_State; type Command_Lib is abstract new Command_Type with null record; @@ -36,7 +37,7 @@ package Ghdllocal is procedure Decode_Option (Cmd : in out Command_Lib; Option : String; Arg : String; - Res : out Option_Res); + Res : out Option_State); -- Disp detailled help. procedure Disp_Long_Help (Cmd : Command_Lib); diff --git a/src/ghdldrv/ghdlmain.adb b/src/ghdldrv/ghdlmain.adb index 402565b9e..12d30bba8 100644 --- a/src/ghdldrv/ghdlmain.adb +++ b/src/ghdldrv/ghdlmain.adb @@ -21,8 +21,8 @@ with Ada.Command_Line.Response_File; with Simple_IO; with Version; with Bug; -with Options; with Types; use Types; +with Errorout; use Errorout; with Errorout.Console; package body Ghdlmain is @@ -36,13 +36,13 @@ package body Ghdlmain is procedure Decode_Option (Cmd : in out Command_Type; Option : String; Arg : String; - Res : out Option_Res) + Res : out Option_State) is pragma Unreferenced (Cmd); pragma Unreferenced (Option); pragma Unreferenced (Arg); begin - Res := Option_Bad; + Res := Option_Unknown; end Decode_Option; procedure Disp_Long_Help (Cmd : Command_Type) @@ -87,7 +87,7 @@ package body Ghdlmain is procedure Decode_Option (Cmd : in out Command_Help; Option : String; Arg : String; - Res : out Option_Res); + Res : out Option_State); function Get_Short_Help (Cmd : Command_Help) return String; procedure Perform_Action (Cmd : Command_Help; Args : Argument_List); @@ -102,7 +102,7 @@ package body Ghdlmain is procedure Decode_Option (Cmd : in out Command_Help; Option : String; Arg : String; - Res : out Option_Res) + Res : out Option_State) is pragma Unreferenced (Cmd); pragma Unreferenced (Option); @@ -249,16 +249,12 @@ package body Ghdlmain is end Perform_Action; -- Disp MSG on the standard output with the command name. - procedure Error (Msg : String) - is - use Errorout; + procedure Error (Msg : String)is begin Report_Msg (Msgid_Error, Option, No_Source_Coord, Msg); end Error; - procedure Warning (Msg : String) - is - use Errorout; + procedure Warning (Msg : String) is begin Report_Msg (Msgid_Warning, Option, No_Source_Coord, Msg); end Warning; @@ -356,7 +352,7 @@ package body Ghdlmain is while Arg_Index <= Args'Last loop declare Arg : constant String_Access := Args (Arg_Index); - Res : Option_Res; + Res : Option_State; begin if Arg (1) = '-' then -- Argument is an option. @@ -368,7 +364,7 @@ package body Ghdlmain is Decode_Option (Cmd.all, Arg.all, "", Res); case Res is - when Option_Bad => + when Option_Unknown => Error ("unknown option '" & Arg.all & "' for command '" & Cmd_Name.all & "'"); raise Option_Error; diff --git a/src/ghdldrv/ghdlmain.ads b/src/ghdldrv/ghdlmain.ads index 226dc9f94..b9958ec61 100644 --- a/src/ghdldrv/ghdlmain.ads +++ b/src/ghdldrv/ghdlmain.ads @@ -16,7 +16,7 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with GNAT.OS_Lib; use GNAT.OS_Lib; -with Errorout; +with Options; use Options; package Ghdlmain is type Command_Type; @@ -34,20 +34,10 @@ package Ghdlmain is -- Initialize the command, before decoding actions. procedure Init (Cmd : in out Command_Type); - -- Option_OK: OPTION is handled. - -- Option_Bad: OPTION is unknown. - -- Option_Err: OPTION has an error (message was displayed). - -- Option_Arg_Req: OPTION requires an argument. Must be set only when - -- ARG = "", the manager will recall Decode_Option. - -- Option_Arg: OPTION used the argument. - type Option_Res is - (Option_Bad, Option_Err, - Option_Ok, Option_Arg, Option_Arg_Req, - Option_End); procedure Decode_Option (Cmd : in out Command_Type; Option : String; Arg : String; - Res : out Option_Res); + Res : out Option_State); -- Get a one-line help for the command. -- If the first character is '!', the string is not displayed by --help @@ -72,9 +62,6 @@ package Ghdlmain is -- Return the index of C in STR, or 0 if not found. function Index (Str : String; C : Character) return Natural; - -- May be raise by perform_action if the arguments are bad. - Option_Error : exception renames Errorout.Option_Error; - -- Action failed. Compile_Error : exception; diff --git a/src/ghdldrv/ghdlprint.adb b/src/ghdldrv/ghdlprint.adb index b93cd147b..8cd8de53f 100644 --- a/src/ghdldrv/ghdlprint.adb +++ b/src/ghdldrv/ghdlprint.adb @@ -25,6 +25,7 @@ with Flags; with Name_Table; use Name_Table; with Files_Map; with Libraries; +with Options; use Options; with Errorout; use Errorout; with Vhdl.Errors; use Vhdl.Errors; with Vhdl.Utils; use Vhdl.Utils; @@ -971,7 +972,7 @@ package body Ghdlprint is procedure Decode_Option (Cmd : in out Command_Reprint; Option : String; Arg : String; - Res : out Option_Res); + Res : out Option_State); procedure Perform_Action (Cmd : Command_Reprint; Args : Argument_List); @@ -993,7 +994,7 @@ package body Ghdlprint is procedure Decode_Option (Cmd : in out Command_Reprint; Option : String; Arg : String; - Res : out Option_Res) + Res : out Option_State) is pragma Assert (Option'First = 1); begin @@ -1207,14 +1208,14 @@ package body Ghdlprint is procedure Decode_Option (Cmd : in out Command_Html; Option : String; Arg : String; - Res : out Option_Res); + Res : out Option_State); procedure Disp_Long_Help (Cmd : Command_Html); procedure Decode_Option (Cmd : in out Command_Html; Option : String; Arg : String; - Res : out Option_Res) is + Res : out Option_State) is begin if Option = "--format=css" then Html_Format := Html_Css; @@ -1307,7 +1308,7 @@ package body Ghdlprint is procedure Decode_Option (Cmd : in out Command_Xref_Html; Option : String; Arg : String; - Res : out Option_Res); + Res : out Option_State); procedure Disp_Long_Help (Cmd : Command_Xref_Html); procedure Perform_Action (Cmd : Command_Xref_Html; @@ -1331,8 +1332,7 @@ package body Ghdlprint is procedure Decode_Option (Cmd : in out Command_Xref_Html; Option : String; Arg : String; - Res : out Option_Res) - is + Res : out Option_State) is begin if Option = "-o" then if Arg = "" then diff --git a/src/ghdldrv/ghdlsynth.adb b/src/ghdldrv/ghdlsynth.adb index f887279a7..4e296dc76 100644 --- a/src/ghdldrv/ghdlsynth.adb +++ b/src/ghdldrv/ghdlsynth.adb @@ -20,6 +20,7 @@ with Ghdllocal; use Ghdllocal; with Ghdlcomp; with Ghdlmain; use Ghdlmain; with Ghdlsimul; +with Options; use Options; with Simul.Annotations; @@ -44,7 +45,7 @@ package body Ghdlsynth is procedure Decode_Option (Cmd : in out Command_Synth; Option : String; Arg : String; - Res : out Option_Res); + Res : out Option_State); procedure Perform_Action (Cmd : Command_Synth; Args : Argument_List); @@ -66,7 +67,7 @@ package body Ghdlsynth is procedure Decode_Option (Cmd : in out Command_Synth; Option : String; Arg : String; - Res : out Option_Res) is + Res : out Option_State) is begin if Option = "--disp-noinline" then Cmd.Disp_Inline := False; diff --git a/src/ghdldrv/ghdlvpi.adb b/src/ghdldrv/ghdlvpi.adb index e2e142d6a..8b79b98c6 100644 --- a/src/ghdldrv/ghdlvpi.adb +++ b/src/ghdldrv/ghdlvpi.adb @@ -19,6 +19,7 @@ with GNAT.OS_Lib; use GNAT.OS_Lib; with Ada.Command_Line; use Ada.Command_Line; with Simple_IO; use Simple_IO; +with Options; use Options; with Ghdlmain; use Ghdlmain; with Ghdllocal; @@ -211,13 +212,13 @@ package body Ghdlvpi is procedure Decode_Option (Cmd : in out Command_Spawn_Type; Option : String; Arg : String; - Res : out Option_Res); + Res : out Option_State); procedure Decode_Option (Cmd : in out Command_Spawn_Type; Option : String; Arg : String; - Res : out Option_Res) + Res : out Option_State) is pragma Unreferenced (Arg); begin @@ -225,7 +226,7 @@ package body Ghdlvpi is Cmd.Flag_Verbose := True; Res := Option_Ok; else - Res := Option_Bad; + Res := Option_Unknown; end if; end Decode_Option; diff --git a/src/libraries.adb b/src/libraries.adb index 30128749d..715538c90 100644 --- a/src/libraries.adb +++ b/src/libraries.adb @@ -21,6 +21,7 @@ with GNAT.OS_Lib; with Logging; use Logging; with Tables; with Errorout; use Errorout; +with Options; use Options; with Vhdl.Errors; use Vhdl.Errors; with Vhdl.Scanner; with Vhdl.Utils; use Vhdl.Utils; @@ -671,6 +672,7 @@ package body Libraries is and then not Flags.Bootstrap then Error_Msg_Option ("cannot find ""std"" library"); + raise Option_Error; end if; if Build_Standard then @@ -693,7 +695,7 @@ package body Libraries is if Work_Library_Name = Name_Std then if not Flags.Bootstrap then Error_Msg_Option ("the WORK library cannot be STD"); - return; + raise Option_Error; end if; Work_Library := Std_Library; else diff --git a/src/options.adb b/src/options.adb index 3f6b9747b..b8a7ec6ad 100644 --- a/src/options.adb +++ b/src/options.adb @@ -39,14 +39,14 @@ package body Options is PSL.Dump_Tree.Dump_Hdl_Node := Vhdl.Disp_Tree.Disp_Tree_For_Psl'Access; end Initialize; - function Option_Warning (Opt: String; Val : Boolean) return Boolean is + function Option_Warning (Opt: String; Val : Boolean) return Option_State is begin -- Handle -Werror. if Opt = "error" then for I in Msgid_Warnings loop Warning_Error (I, Val); end loop; - return True; + return Option_Ok; end if; -- Handle -Werror=xxx @@ -56,31 +56,33 @@ package body Options is for I in Msgid_Warnings loop if Warning_Image (I) = Opt (Opt'First + 6 .. Opt'Last) then Warning_Error (I, Val); - return True; + return Option_Ok; end if; end loop; - return False; + Error_Msg_Option ("unknown warning identifier"); + return Option_Err; end if; -- Normal warnings. for I in Msgid_Warnings loop if Warning_Image (I) = Opt then Enable_Warning (I, Val); - return True; + return Option_Ok; end if; end loop; -- -Wreserved is an alias for -Wreserved-word. if Opt = "reserved" then Enable_Warning (Warnid_Reserved_Word, Val); - return True; + return Option_Ok; end if; -- Unknown warning. - return False; + Error_Msg_Option ("unknown warning identifier"); + return Option_Err; end Option_Warning; - function Parse_Option (Opt : String) return Boolean + function Parse_Option (Opt : String) return Option_State is pragma Assert (Opt'First = 1); begin @@ -97,24 +99,26 @@ package body Options is elsif Opt (7 .. 8) = "08" then Vhdl_Std := Vhdl_08; else - return False; + Error_Msg_Option ("unknown language standard"); + return Option_Err; end if; elsif Opt'Length = 9 and then Opt (7 .. 9) = "93c" then Vhdl_Std := Vhdl_93c; else - return False; + Error_Msg_Option ("unknown language standard"); + return Option_Err; end if; elsif Opt'Length = 5 and then Opt (1 .. 5) = "--ams" then AMS_Vhdl := True; elsif Opt'Length >= 2 and then Opt (1 .. 2) = "-P" then if Opt'Last = 2 then Error_Msg_Option ("missing directory after -P"); - return True; + return Option_Err; end if; if Opt (3) = '=' then if Opt'Last = 3 then Error_Msg_Option ("missing directory after -P="); - return True; + return Option_Err; end if; Libraries.Add_Library_Path (Opt (4 .. Opt'Last)); else @@ -136,9 +140,13 @@ package body Options is declare use Name_Table; Name : String (1 .. Opt'Last - 8 + 1); + Err : Boolean; begin Name := Opt (8 .. Opt'Last); - Vhdl.Scanner.Convert_Identifier (Name); + Vhdl.Scanner.Convert_Identifier (Name, Err); + if Err then + return Option_Err; + end if; Libraries.Work_Library_Name := Get_Identifier (Name); end; elsif Opt = "-C" or else Opt = "--mb-comments" then @@ -166,13 +174,13 @@ package body Options is V := Natural'Value (Opt (11 .. Opt'Last)); if V not in Tab_Stop_Range then Error_Msg_Option ("incorrect value for -ftabstop"); - return True; + return Option_Err; end if; Tab_Stop := V; exception when Constraint_Error => Error_Msg_Option ("numeric value expected after -ftabstop="); - return True; + return Option_Err; end; elsif Opt = "--bootstrap" then Bootstrap := True; @@ -224,9 +232,9 @@ package body Options is then null; else - return False; + return Option_Unknown; end if; - return True; + return Option_Ok; end Parse_Option; -- Disp help about these options. diff --git a/src/options.ads b/src/options.ads index 68acc8c75..4b73a3ec7 100644 --- a/src/options.ads +++ b/src/options.ads @@ -17,14 +17,38 @@ -- 02111-1307, USA. package Options is + -- How an option was handled by Parse_Option. + type Option_State is + ( + -- Option correctly parsed. + Option_Ok, + + -- Option is unknown. + Option_Unknown, + + -- Option has an error (message was displayed). + Option_Err, + + -- Option_Arg_Req: OPTION requires an argument. Must be set only when + -- ARG = "", the manager will recall Decode_Option. + Option_Arg_Req, + + -- Option_Arg: OPTION used the argument. + Option_Arg, + + Option_End + ); + -- Return true if opt is recognize by flags. -- Note: std_names.std_names_initialize and files_map.init_paths must have -- been called before this subprogram. - function Parse_Option (Opt : String) return Boolean; + function Parse_Option (Opt : String) return Option_State; -- Disp help about these options. procedure Disp_Options_Help; -- Front-end intialization. procedure Initialize; + + Option_Error: exception; end Options; diff --git a/src/vhdl/libghdl/libghdl.adb b/src/vhdl/libghdl/libghdl.adb index 7226e5295..b0442b9f4 100644 --- a/src/vhdl/libghdl/libghdl.adb +++ b/src/vhdl/libghdl/libghdl.adb @@ -19,6 +19,7 @@ with GNAT.OS_Lib; use GNAT.OS_Lib; with Ghdllocal; with Ghdlcomp; +with Options; use Options; with Errorout.Memory; with Files_Map.Editor; with Vhdl.Formatters; @@ -29,7 +30,7 @@ pragma Unreferenced (Vhdl.Formatters); package body Libghdl is function Set_Option (Opt : Thin_String_Ptr; Len : Natural) return Integer is begin - if Ghdllocal.Decode_Driver_Option (Opt (1 .. Len)) then + if Ghdllocal.Decode_Driver_Option (Opt (1 .. Len)) = Option_Ok then -- Ok. return 0; else diff --git a/src/vhdl/translate/ortho_front.adb b/src/vhdl/translate/ortho_front.adb index ea375b1d0..935d5c9d0 100644 --- a/src/vhdl/translate/ortho_front.adb +++ b/src/vhdl/translate/ortho_front.adb @@ -17,16 +17,17 @@ -- 02111-1307, USA. with System; with Interfaces.C_Streams; +with GNAT.OS_Lib; with Types; use Types; with Name_Table; with Hash; with Interning; -with Vhdl.Nodes; use Vhdl.Nodes; +with Flags; with Libraries; +with Vhdl.Nodes; use Vhdl.Nodes; with Vhdl.Utils; use Vhdl.Utils; with Vhdl.Std_Package; -with Flags; with Vhdl.Configuration; with Translation; with Vhdl.Sem; @@ -34,10 +35,9 @@ with Vhdl.Sem_Lib; use Vhdl.Sem_Lib; with Errorout; use Errorout; with Errorout.Console; with Vhdl.Errors; use Vhdl.Errors; -with GNAT.OS_Lib; with Bug; with Trans_Be; -with Options; +with Options; use Options; package body Ortho_Front is -- The action to be performed by the compiler. @@ -232,13 +232,13 @@ package body Ortho_Front is subtype Str_Type is String (1 .. Opt'Last - 6); begin -- The option parameter must be normalized (starts at index 1). - if Options.Parse_Option (Str_Type (Opt (7 .. Opt'Last))) then + if Parse_Option (Str_Type (Opt (7 .. Opt'Last))) = Option_Ok then return 1; else return 0; end if; end; - elsif Options.Parse_Option (Opt.all) then + elsif Options.Parse_Option (Opt.all) = Option_Ok then return 1; else return 0; diff --git a/src/vhdl/vhdl-scanner.adb b/src/vhdl/vhdl-scanner.adb index 8089daf1d..2f7f37544 100644 --- a/src/vhdl/vhdl-scanner.adb +++ b/src/vhdl/vhdl-scanner.adb @@ -1451,7 +1451,7 @@ package body Vhdl.Scanner is Current_Token := Tok_Identifier; end Scan_Extended_Identifier; - procedure Convert_Identifier (Str : in out String) + procedure Convert_Identifier (Str : in out String; Err : out Boolean) is procedure Error_Bad is begin @@ -1467,6 +1467,8 @@ package body Vhdl.Scanner is subtype Id_Subtype is String (1 .. Str'Length); Id : Id_Subtype renames Str; begin + Err := True; + if Id'Length = 0 then Error_Msg_Option ("identifier required"); return; @@ -1505,6 +1507,7 @@ package body Vhdl.Scanner is end if; when Invalid => Error_Bad; + return; end case; end loop; else @@ -1515,11 +1518,13 @@ package body Vhdl.Scanner is when Upper_Case_Letter => if Vhdl_Std = Vhdl_87 and C > 'Z' then Error_8bit; + return; end if; Id (I) := To_Lower_Map (C); when Lower_Case_Letter | Digit => if Vhdl_Std = Vhdl_87 and C > 'z' then Error_8bit; + return; end if; when Special_Character => -- The current character is legal in an identifier. @@ -1541,12 +1546,15 @@ package body Vhdl.Scanner is end if; else Error_Bad; + return; end if; when others => Error_Bad; + return; end case; end loop; end if; + Err := False; end Convert_Identifier; -- Internal scanner function: return True if C must be considered as a line diff --git a/src/vhdl/vhdl-scanner.ads b/src/vhdl/vhdl-scanner.ads index f0afb1e0c..e6eedb0b8 100644 --- a/src/vhdl/vhdl-scanner.ads +++ b/src/vhdl/vhdl-scanner.ads @@ -137,9 +137,9 @@ package Vhdl.Scanner is -- Lexical checks are performed. -- This procedure is not used by Scan, but should be used for identifiers -- given in the command line. - -- Errors are directly reported through error_msg_option. + -- Errors are directly reported through error_msg_option, and ERR set. -- Also, Vhdl_Std should be set. - procedure Convert_Identifier (Str : in out String); + procedure Convert_Identifier (Str : in out String; Err : out Boolean); -- Return TRUE iff C is a whitespace. -- LRM93 13.2 Lexical elements, separators, and delimiters -- cgit v1.2.3