Better reporting for TCL errors

nickg · Jan 18, 2025 · 7d70130 · 7d70130
1 parent 1febb2c
commit 7d70130
Show file tree

Hide file tree

Showing 6 changed files with 39 additions and 16 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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);