Add target in bug-box, add --bug-box internal command.

4 files changed, 42 insertions, 1 deletions

diff --git a/src/bug.adb b/src/bug.adb
index 61d41f41a..f7b44210f 100644
--- a/src/bug.adb
+++ b/src/bug.adb
@@ -72,6 +72,7 @@ package body Bug is
          "Please report this bug on https://github.com/tgingold/ghdl/issues");
       Put_Line (Standard_Error, "GHDL release: " & Ghdl_Release);
       Put_Line (Standard_Error, "Compiled with " & Get_Gnat_Version);
+      Put_Line (Standard_Error, "Target: " & Standard'Target_Name);
       Put_Line (Standard_Error, "In directory: " &
                 GNAT.Directory_Operations.Get_Current_Dir);
       --Put_Line
diff --git a/src/ghdldrv/ghdllocal.adb b/src/ghdldrv/ghdllocal.adb
index 3a6910317..229108e5a 100644
--- a/src/ghdldrv/ghdllocal.adb
+++ b/src/ghdldrv/ghdllocal.adb
@@ -1065,6 +1065,37 @@ package body Ghdllocal is
       Disp_Vhdl.Disp_Vhdl (Std_Package.Std_Standard_Unit);
    end Perform_Action;
 
+   --  Command --bug-box.
+   type Command_Bug_Box is new Command_Type with null record;
+   function Decode_Command (Cmd : Command_Bug_Box; Name : String)
+                           return Boolean;
+   function Get_Short_Help (Cmd : Command_Bug_Box) return String;
+   procedure Perform_Action (Cmd : in out Command_Bug_Box;
+                             Args : Argument_List);
+
+   function Decode_Command (Cmd : Command_Bug_Box; Name : String)
+                           return Boolean
+   is
+      pragma Unreferenced (Cmd);
+   begin
+      return Name = "--bug-box";
+   end Decode_Command;
+
+   function Get_Short_Help (Cmd : Command_Bug_Box) return String
+   is
+      pragma Unreferenced (Cmd);
+   begin
+      return "!--bug-box          Crash and emit a bug-box";
+   end Get_Short_Help;
+
+   procedure Perform_Action (Cmd : in out Command_Bug_Box;
+                             Args : Argument_List)
+   is
+      pragma Unreferenced (Cmd, Args);
+   begin
+      raise Program_Error;
+   end Perform_Action;
+
    procedure Load_All_Libraries_And_Files
    is
       use Files_Map;
@@ -1508,5 +1539,6 @@ package body Ghdllocal is
       Register_Command (new Command_Remove);
       Register_Command (new Command_Copy);
       Register_Command (new Command_Disp_Standard);
+      Register_Command (new Command_Bug_Box);
    end Register_Commands;
 end Ghdllocal;
diff --git a/src/ghdldrv/ghdlmain.adb b/src/ghdldrv/ghdlmain.adb
index 2f1d37e8d..abe7dc045 100644
--- a/src/ghdldrv/ghdlmain.adb
+++ b/src/ghdldrv/ghdlmain.adb
@@ -129,7 +129,13 @@ package body Ghdlmain is
          Put_Line ("COMMAND is one of:");
          C := First_Cmd;
          while C /= null loop
-            Put_Line (Get_Short_Help (C.all));
+            declare
+               S : constant String := Get_Short_Help (C.all);
+            begin
+               if S'Length > 1 and then S (S'First) /= '!' then
+                  Put_Line (S);
+               end if;
+            end;
             C := C.Next;
          end loop;
          New_Line;
diff --git a/src/ghdldrv/ghdlmain.ads b/src/ghdldrv/ghdlmain.ads
index 9b13486c8..c79530934 100644
--- a/src/ghdldrv/ghdlmain.ads
+++ b/src/ghdldrv/ghdlmain.ads
@@ -47,6 +47,8 @@ package Ghdlmain is
                             Res : out Option_Res);
 
    --  Get a one-line help for the command.
+   --  If the first character is '!', the string is not displayed by --help
+   --  (for internal commands).
    function Get_Short_Help (Cmd : Command_Type) return String
      is abstract;