From 7d70130c5cd5d55b4e07410f25638a930a70b3bc Mon Sep 17 00:00:00 2001
From: Nick Gasson <nick@nickg.me.uk>
Date: Sat, 18 Jan 2025 16:32:34 +0000
Subject: [PATCH] Better reporting for TCL errors

---
 src/diag.c                 |  3 ++-
 src/rt/shell.c             | 31 +++++++++++++++++--------------
 test/regress/gold/tcl3.txt | 10 ++++++++++
 test/regress/tcl3.tcl      |  9 +++++++++
 test/regress/testlist.txt  |  1 +
 test/test_shell.c          |  1 -
 6 files changed, 39 insertions(+), 16 deletions(-)
 create mode 100644 test/regress/gold/tcl3.txt
 create mode 100644 test/regress/tcl3.tcl

diff --git a/src/diag.c b/src/diag.c
index bf818a1cd..556e71dca 100644
--- a/src/diag.c
+++ b/src/diag.c
@@ -868,7 +868,8 @@ static void diag_emit_hints(diag_t *d, FILE *f)
          color_fprintf(f, "%*s", first_col, "");
 
          int ncarets = 1;
-         if (hint->loc.line_delta == 0)
+         if (hint->loc.line_delta == 0
+             && hint->loc.column_delta != DELTA_INVALID)
             ncarets = hint->loc.column_delta + 1;
 
          const int hintcol = fwidth + hint->loc.first_column + ncarets + 4;
diff --git a/src/rt/shell.c b/src/rt/shell.c
index 7bed27b4f..45d5e55a0 100644
--- a/src/rt/shell.c
+++ b/src/rt/shell.c
@@ -1325,16 +1325,22 @@ void shell_free(tcl_shell_t *sh)
 bool shell_eval(tcl_shell_t *sh, const char *script, const char **result)
 {
    const int code = Tcl_Eval(sh->interp, script);
-   const char *str = Tcl_GetStringResult(sh->interp);
 
    switch (code) {
    case TCL_OK:
       if (result != NULL)
-         *result = str;
+         *result = Tcl_GetStringResult(sh->interp);
       return true;
    case TCL_ERROR:
-      if (str != NULL && *str != '\0')
-         errorf("%s", str);
+      {
+         const char *info = Tcl_GetVar(sh->interp, "::errorInfo", 0);
+         if (info != NULL && *info != '\n')
+            errorf("%s", info);
+
+         *result = Tcl_GetStringResult(sh->interp);
+         if (info == NULL && *result != NULL && **result != '\0')
+            errorf("%s", *result);
+      }
       return false;
    default:
       warnf("Tcl_Eval returned unknown code %d", code);
@@ -1462,16 +1468,13 @@ bool shell_do(tcl_shell_t *sh, const char *file)
       return true;
    case TCL_ERROR:
       {
-         const char *str = Tcl_GetStringResult(sh->interp);
-         if (str != NULL && *str != '\0') {
-            diag_t *d = diag_new(DIAG_ERROR, NULL);
-            diag_printf(d, "%s", str);
-
-            const char *info = Tcl_GetVar(sh->interp, "::errorInfo", 0);
-            if (info != NULL)
-               diag_hint(d, NULL, "%s", info);
-
-            diag_emit(d);
+         const char *info = Tcl_GetVar(sh->interp, "::errorInfo", 0);
+         if (info != NULL && *info != '\n')
+            errorf("%s", info);
+         else {
+            const char *str = Tcl_GetStringResult(sh->interp);
+            if (str != NULL && *str != '\0')
+               errorf("%s", str);
          }
 
          return false;
diff --git a/test/regress/gold/tcl3.txt b/test/regress/gold/tcl3.txt
new file mode 100644
index 000000000..4f672c2a8
--- /dev/null
+++ b/test/regress/gold/tcl3.txt
@@ -0,0 +1,10 @@
+boo
+while executing
+"error "boo""
+(procedure "proc2" line 2)
+invoked from within
+"proc2"
+(procedure "proc1" line 2)
+invoked from within
+"proc1"
+(file "
diff --git a/test/regress/tcl3.tcl b/test/regress/tcl3.tcl
new file mode 100644
index 000000000..d619cfd68
--- /dev/null
+++ b/test/regress/tcl3.tcl
@@ -0,0 +1,9 @@
+proc proc2 args {
+    error "boo"
+}
+
+proc proc1 args {
+    proc2
+}
+
+proc1
diff --git a/test/regress/testlist.txt b/test/regress/testlist.txt
index 183e86ec5..a621eb72f 100644
--- a/test/regress/testlist.txt
+++ b/test/regress/testlist.txt
@@ -1093,3 +1093,4 @@ cmdline13       shell
 issue1117       normal,psl,2008
 issue1125       normal,2008
 issue1137       normal
+tcl3            tcl,fail,gold
diff --git a/test/test_shell.c b/test/test_shell.c
index 9e7a8278b..a7de2b26b 100644
--- a/test/test_shell.c
+++ b/test/test_shell.c
@@ -47,7 +47,6 @@ START_TEST(test_analyse)
 
    const char *result = NULL;
    fail_if(shell_eval(sh, "analyse " TESTDIR "/parse/entity.vhd", &result));
-   ck_assert_ptr_eq(result, NULL);
 
    tree_t one = lib_get(lib_work(), ident_new("WORK.ONE"));
    fail_if(one == NULL);