From ab1a4bd15ed0d9e8c8ecbffd62e11e2c78ff1f28 Mon Sep 17 00:00:00 2001
From: Tristan Gingold <tgingold@free.fr>
Date: Mon, 25 May 2020 19:48:09 +0200
Subject: grt: implement --backtrace-severity.  For #1338

---
 src/grt/grt-lib.adb      |  4 ++++
 src/grt/grt-options.adb  | 52 ++++++++++++++++++++++++++++++++++++------------
 src/grt/grt-options.ads  |  4 ++++
 src/grt/grt-severity.ads |  3 +++
 4 files changed, 50 insertions(+), 13 deletions(-)

(limited to 'src/grt')

diff --git a/src/grt/grt-lib.adb b/src/grt/grt-lib.adb
index 66d1ccccf..3bd3440ec 100644
--- a/src/grt/grt-lib.adb
+++ b/src/grt/grt-lib.adb
@@ -29,6 +29,7 @@ with Grt.Errors_Exec; use Grt.Errors_Exec;
 with Grt.Severity;
 with Grt.Options;
 with Grt.Fcvt;
+with Grt.Backtraces;
 
 package body Grt.Lib is
    --procedure Memcpy (Dst : Address; Src : Address; Size : Size_T);
@@ -89,6 +90,9 @@ package body Grt.Lib is
          Error_S (Msg);
          Diag_C (" failed");
          Error_E_Call_Stack (Bt);
+      elsif Level >= Grt.Options.Backtrace_Severity then
+         Save_Backtrace (Bt, 2);
+         Grt.Backtraces.Put_Err_Backtrace (Bt);
       end if;
    end Do_Report;
 
diff --git a/src/grt/grt-options.adb b/src/grt/grt-options.adb
index 379d1978e..097a9d6da 100644
--- a/src/grt/grt-options.adb
+++ b/src/grt/grt-options.adb
@@ -71,6 +71,7 @@ package body Grt.Options is
       P (" --help, -h        disp this help");
       P (" --assert-level=LEVEL   stop simulation if assert at LEVEL");
       P ("       LEVEL is note,warning,error,failure,none");
+      P (" --backtrace-severity=LEVEL  display a backtrace for assertions");
       P (" --ieee-asserts=POLICY  enable or disable asserts from IEEE");
       P ("       POLICY is enable,disable,disable-at-0");
       P (" --stop-time=X     stop the simulation at time X");
@@ -191,6 +192,26 @@ package body Grt.Options is
       return Std_Time (Time);
    end Parse_Time;
 
+   function Parse_Severity (Opt_Name : String; Arg : String) return Integer is
+   begin
+      if Arg = "note" then
+         return Note_Severity;
+      elsif Arg = "warning" then
+         return Warning_Severity;
+      elsif Arg = "error" then
+         return Error_Severity;
+      elsif Arg = "failure" then
+         return Failure_Severity;
+      elsif Arg = "none" then
+         return 4;
+      else
+         Error_S ("bad argument for ");
+         Diag_C (Opt_Name);
+         Error_E (" option, try --help");
+         return -1;
+      end if;
+   end Parse_Severity;
+
    procedure Decode_Option
      (Option : String; Status : out Decode_Option_Status)
    is
@@ -265,19 +286,24 @@ package body Grt.Options is
             end if;
          end;
       elsif Len > 15 and then Option (1 .. 15) = "--assert-level=" then
-         if Option (16 .. Len) = "note" then
-            Severity_Level := Note_Severity;
-         elsif Option (16 .. Len) = "warning" then
-            Severity_Level := Warning_Severity;
-         elsif Option (16 .. Len) = "error" then
-            Severity_Level := Error_Severity;
-         elsif Option (16 .. Len) = "failure" then
-            Severity_Level := Failure_Severity;
-         elsif Option (16 .. Len) = "none" then
-            Severity_Level := 4;
-         else
-            Error ("bad argument for --assert-level option, try --help");
-         end if;
+         declare
+            Level : Integer;
+         begin
+            Level := Parse_Severity ("--assert-level", Option (16 .. Len));
+            if Level >= 0 then
+               Severity_Level := Level;
+            end if;
+         end;
+      elsif Len > 21 and then Option (1 .. 21) = "--backtrace-severity=" then
+         declare
+            Level : Integer;
+         begin
+            Level := Parse_Severity
+              ("--backtrace-severity", Option (22 .. Len));
+            if Level >= 0 then
+               Backtrace_Severity := Level;
+            end if;
+         end;
       elsif Len > 15 and then Option (1 .. 15) = "--ieee-asserts=" then
          if Option (16 .. Len) = "disable" then
             Ieee_Asserts := Disable_Asserts;
diff --git a/src/grt/grt-options.ads b/src/grt/grt-options.ads
index 3d5a8bf15..495391e43 100644
--- a/src/grt/grt-options.ads
+++ b/src/grt/grt-options.ads
@@ -119,9 +119,13 @@ package Grt.Options is
    --  Set by --checks to do internal checks.
    Checks : Boolean := False;
 
+   --  For --assert-level
    --  Level at which an assert stop the simulation.
    Severity_Level : Integer := Grt.Severity.Failure_Severity;
 
+   --  Level at which an assert displays a backtrace.
+   Backtrace_Severity : Integer := Grt.Severity.None_Severity;
+
    --  How assertions are handled.
    type Assert_Handling is
      (Enable_Asserts,
diff --git a/src/grt/grt-severity.ads b/src/grt/grt-severity.ads
index 75d8d90d9..681f3c30c 100644
--- a/src/grt/grt-severity.ads
+++ b/src/grt/grt-severity.ads
@@ -30,4 +30,7 @@ package Grt.Severity is
    Warning_Severity : constant Integer := 1;
    Error_Severity   : constant Integer := 2;
    Failure_Severity : constant Integer := 3;
+
+   --  Value returned by Parse_Severity for 'none'.
+   None_Severity    : constant Integer := 4;
 end Grt.Severity;
-- 
cgit v1.2.3