Add the [xtrace] command

Allows a debugger or tracing facility to be implemented

Signed-off-by: Steve Bennett <steveb@workware.net.au>

4 files changed, 168 insertions, 12 deletions

diff --git a/jim.c b/jim.c
index 31b04e2..0de2f3e 100644
--- a/jim.c
+++ b/jim.c
@@ -5715,6 +5715,9 @@ void Jim_FreeInterp(Jim_Interp *i)
     Jim_FreeHashTable(&i->packages);
     Jim_Free(i->prngState);
     Jim_FreeHashTable(&i->assocData);
+    if (i->traceCmdObj) {
+        Jim_DecrRefCount(i, i->traceCmdObj);
+    }
 
     /* Check that the live object list is empty, otherwise
      * there is a memory leak. */
@@ -10492,6 +10495,45 @@ static int Jim_IncrCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *arg
 #define JIM_EVAL_SARGV_LEN 8    /* static arguments vector length */
 #define JIM_EVAL_SINTV_LEN 8    /* static interpolation vector length */
 
+static int JimTraceCallback(Jim_Interp *interp, const char *type, int argc, Jim_Obj *const *argv)
+{
+    JimPanic((interp->traceCmdObj == NULL, "xtrace invoked with no object"));
+
+    int ret;
+    Jim_Obj *nargv[7];
+    Jim_Obj *traceCmdObj = interp->traceCmdObj;
+    Jim_Obj *resultObj = Jim_GetResult(interp);
+    /* Where were we called from? */
+    ScriptObj *script = JimGetScript(interp, interp->currentScriptObj);
+
+    nargv[0] = traceCmdObj;
+    nargv[1] = Jim_NewStringObj(interp, type, -1);
+    nargv[2] = script->fileNameObj;
+    nargv[3] = Jim_NewIntObj(interp, script->linenr);
+    nargv[4] = resultObj;
+    nargv[5] = argv[0];
+    nargv[6] = Jim_NewListObj(interp, argv + 1, argc - 1);
+
+    /* Remove the trace while executing the trace callback */
+    interp->traceCmdObj = NULL;
+    /* Invoke the callback */
+    Jim_IncrRefCount(resultObj);
+    ret = Jim_EvalObjVector(interp, 7, nargv);
+    Jim_DecrRefCount(interp, resultObj);
+
+    if (ret == JIM_OK || ret == JIM_RETURN) {
+        /* Reinstall the trace callback */
+        interp->traceCmdObj = traceCmdObj;
+        Jim_SetEmptyResult(interp);
+        ret = JIM_OK;
+    }
+    else {
+        /* No more tracing */
+        Jim_DecrRefCount(interp, traceCmdObj);
+    }
+    return ret;
+}
+
 /* Handle calls to the [unknown] command */
 static int JimUnknown(Jim_Interp *interp, int argc, Jim_Obj *const *argv)
 {
@@ -10553,14 +10595,17 @@ static int JimInvokeCommand(Jim_Interp *interp, int objc, Jim_Obj *const *objv)
 
 tailcall:
 
-    /* Call it -- Make sure result is an empty object. */
-    Jim_SetEmptyResult(interp);
-    if (cmdPtr->isproc) {
-        retcode = JimCallProcedure(interp, cmdPtr, objc, objv);
-    }
-    else {
-        interp->cmdPrivData = cmdPtr->u.native.privData;
-        retcode = cmdPtr->u.native.cmdProc(interp, objc, objv);
+    if (!interp->traceCmdObj ||
+        (retcode = JimTraceCallback(interp, "cmd", objc, objv)) == JIM_OK) {
+        /* Call it -- Make sure result is an empty object. */
+        Jim_SetEmptyResult(interp);
+        if (cmdPtr->isproc) {
+            retcode = JimCallProcedure(interp, cmdPtr, objc, objv);
+        }
+        else {
+            interp->cmdPrivData = cmdPtr->u.native.privData;
+            retcode = cmdPtr->u.native.cmdProc(interp, objc, objv);
+        }
     }
 
     if (tailcallObj) {
@@ -11295,8 +11340,11 @@ static int JimCallProcedure(Jim_Interp *interp, Jim_Cmd *cmd, int argc, Jim_Obj
         }
     }
 
-    /* Eval the body */
-    retcode = Jim_EvalObj(interp, cmd->u.proc.bodyObjPtr);
+    if (interp->traceCmdObj == NULL ||
+        (retcode = JimTraceCallback(interp, "proc", argc, argv)) == JIM_OK) {
+        /* Eval the body */
+        retcode = Jim_EvalObj(interp, cmd->u.proc.bodyObjPtr);
+    }
 
 badargset:
 
@@ -13574,6 +13622,27 @@ static int Jim_ProcCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *arg
     return JIM_ERR;
 }
 
+/* [xtrace] */
+static int Jim_XtraceCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv)
+{
+    if (argc != 2) {
+        Jim_WrongNumArgs(interp, 1, argv, "callback");
+        return JIM_ERR;
+    }
+
+    if (interp->traceCmdObj) {
+        Jim_DecrRefCount(interp, interp->traceCmdObj);
+        interp->traceCmdObj = NULL;
+    }
+
+    if (Jim_Length(argv[1])) {
+        /* Install the new execution trace callback */
+        interp->traceCmdObj = argv[1];
+        Jim_IncrRefCount(interp->traceCmdObj);
+    }
+    return JIM_OK;
+}
+
 /* [local] */
 static int Jim_LocalCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv)
 {
@@ -15835,6 +15904,7 @@ static const struct {
     {"break", Jim_BreakCoreCommand},
     {"continue", Jim_ContinueCoreCommand},
     {"proc", Jim_ProcCoreCommand},
+    {"xtrace", Jim_XtraceCoreCommand},
     {"concat", Jim_ConcatCoreCommand},
     {"return", Jim_ReturnCoreCommand},
     {"upvar", Jim_UpvarCoreCommand},
diff --git a/jim.h b/jim.h
index 79bfc0c..4933bdc 100644
--- a/jim.h
+++ b/jim.h
@@ -133,7 +133,7 @@ extern "C" {
 #define JIM_SIGNAL 5
 #define JIM_EXIT 6
 /* The following are internal codes and should never been seen/used */
-#define JIM_EVAL 7
+#define JIM_EVAL 7      /* tailcall */
 
 #define JIM_MAX_CALLFRAME_DEPTH 1000 /* default max nesting depth for procs */
 #define JIM_MAX_EVAL_DEPTH 2000 /* default max nesting depth for eval */
@@ -567,6 +567,7 @@ typedef struct Jim_Interp {
     Jim_Obj *errorProc; /* Name of last procedure which returned an error */
     Jim_Obj *unknown; /* Unknown command cache */
     Jim_Obj *defer; /* "jim::defer" */
+    Jim_Obj *traceCmdObj; /* If non-null, execution trace command to invoke */
     int unknown_called; /* The unknown command has been invoked */
     int errorFlag; /* Set if an error occurred during execution. */
     void *cmdPrivData; /* Used to pass the private data pointer to
diff --git a/jim_tcl.txt b/jim_tcl.txt
index 24ea60b..6b25338 100644
--- a/jim_tcl.txt
+++ b/jim_tcl.txt
@@ -58,7 +58,8 @@ Changes since 0.80
 2. Many commands now accept "safe" integer expressions rather than simple integers:
    `loop`, `range`, `incr`, `string repeat`, `lrepeat`, `pack`, `unpack`, `rand`
 3. String and list indexes now accept integer expressions (<<_string_and_list_index_specifications,STRING AND LIST INDEX SPECIFICATIONS>>)
-4. `loop` can now omit start value
+4. `loop` can now omit the start value
+5. Add the `xtrace` command for execution trace support
 
 Changes between 0.79 and 0.80
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -4729,6 +4730,28 @@ termination of the `while` command.
 
 The `while` command always returns an empty string.
 
+xtrace
+~~~~~~
++*xtrace* 'command'+
+
+Install an execution trace callback command. This is useful for implementing a debugger
+or tracing tool. On each command invocation, the given command is invoked as:
+
+----
+    command proc|cmd filename line result command arglist
+----
+
++'proc'+ or +'cmd'+ indicates whether a command or a proc body is being executed.
++'filename'+ and +'line'+ indicate the location where the command was invoked.
++'result'+ is the current interpreter result (from the previous command).
++'command'+ and +'arglist'+ indicate the command being executed.
+
+While the callback is executing, any further execution traces are temporarily disabled.
+If the callback returns +JIM_OK+ or +JIM_RETURN+, the execution trace is reinstalled. Otherwise
+the execution trace is removed.
+
+If +*xtrace*+ is called with an empty argument (""), any existing callback is removed.
+
 OPTIONAL-EXTENSIONS
 -------------------
 
diff --git a/tests/xtrace.test b/tests/xtrace.test
new file mode 100644
index 0000000..c55a54e
--- /dev/null
+++ b/tests/xtrace.test
@@ -0,0 +1,62 @@
+source [file dirname [info script]]/testing.tcl
+
+needs cmd xtrace
+
+# Simply accumulate the callback args in the list ::lines
+proc xtracetest {args} {
+	lappend ::lines $args
+}
+
+proc xtracesummary {lines} {
+	# Omit the last line that will always be xtrace {}
+	# Remove file and line
+	lmap line [lrange $lines 0 end-1] {
+		lassign $line type file line result cmd arglist
+		list $type ($result) $cmd $arglist
+	}
+}
+
+proc xtracetestproc {a} {
+	append a " world"
+	return $a
+}
+
+test xtrace-1.1 {xtrace usage} -body {
+	xtrace
+} -returnCodes error -result {wrong # args: should be "xtrace callback"}
+
+test xtrace-1.2 {xtrace non-proc} -body {
+	set lines {}
+	xtrace xtracetest
+	set x 3
+	xtrace {}
+	xtracesummary $lines
+} -result {{cmd () set {x 3}}}
+
+# This will produce 4 calls to the trace callback
+# 1. xtracetestproc hello (cmd)
+# 2. xtracetestproc hello (proc - when executing the proc body)
+# 3. append a " hello"
+# 4. return "hello world" (previous command result will be "hello world")
+test xtrace-1.3 {xtrace proc} -body {
+	set lines {}
+	xtrace xtracetest
+	xtracetestproc hello
+	xtrace {}
+	xtracesummary $lines
+} -result {{cmd () xtracetestproc hello} {proc () xtracetestproc hello} {cmd () append {a { world}}} {cmd {(hello world)} return {{hello world}}}}
+
+test xtrace-1.4 {xtrace line numbers} -body {
+	set lines {}
+	xtrace xtracetest
+	set x abc
+	xtrace {}
+	# Now the first callback should happen at the correct line number
+	lassign [lindex $lines 0] - tracefile traceline
+	lassign [info source $x] file line
+	if {"$tracefile:$traceline" eq "$file:$line"} {
+		function ok
+	}
+} -result {ok}
+
+testreport