diff options
author | Steve Bennett <steveb@workware.net.au> | 2011-12-02 13:24:38 +1000 |
---|---|---|
committer | Steve Bennett <steveb@workware.net.au> | 2021-01-09 11:06:48 +1000 |
commit | fe37b8dc2536b70d0aba3c6a70ead466ebe5b9d6 (patch) | |
tree | f4e3db58f298facf7cf84272d3a3321144c23d32 | |
parent | b8018299ad54fecfdcffe4b22ac994944a716f2a (diff) | |
download | jimtcl-fe37b8dc2536b70d0aba3c6a70ead466ebe5b9d6.zip jimtcl-fe37b8dc2536b70d0aba3c6a70ead466ebe5b9d6.tar.gz jimtcl-fe37b8dc2536b70d0aba3c6a70ead466ebe5b9d6.tar.bz2 |
Add the [xtrace] command
Allows a debugger or tracing facility to be implemented
Signed-off-by: Steve Bennett <steveb@workware.net.au>
-rw-r--r-- | jim.c | 90 | ||||
-rw-r--r-- | jim.h | 3 | ||||
-rw-r--r-- | jim_tcl.txt | 25 | ||||
-rw-r--r-- | tests/xtrace.test | 62 |
4 files changed, 168 insertions, 12 deletions
@@ -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}, @@ -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 |