diff options
| -rw-r--r-- | jim.c | 213 | ||||
| -rw-r--r-- | jim.h | 17 | ||||
| -rw-r--r-- | jim_tcl.txt | 2 | ||||
| -rwxr-xr-x | jimdb | 4 | ||||
| -rw-r--r-- | stdlib.tcl | 26 | ||||
| -rw-r--r-- | tests/apply.test | 6 | ||||
| -rw-r--r-- | tests/infoframe.test | 24 |
7 files changed, 236 insertions, 56 deletions
@@ -4392,6 +4392,12 @@ Jim_Cmd *Jim_GetCommand(Jim_Interp *interp, Jim_Obj *objPtr, int flags) } cmd = Jim_GetHashEntryVal(he); + /* Stash the resolved command name. Note that we don't incr the ref count here + * since we don't want to increase the ref count. The lifetime is the same as the key + * in the commands hash table + */ + cmd->cmdNameObj = Jim_GetHashEntryKey(he); + /* Free the old internal rep and set the new one. */ Jim_FreeIntRep(interp, objPtr); objPtr->typePtr = &commandObjType; @@ -5675,6 +5681,7 @@ Jim_Interp *Jim_CreateInterp(void) i->errorProc = i->emptyObj; i->currentScriptObj = Jim_NewEmptyStringObj(i); i->nullScriptObj = Jim_NewEmptyStringObj(i); + i->evalFrame = &i->topEvalFrame; Jim_IncrRefCount(i->emptyObj); Jim_IncrRefCount(i->errorFileNameObj); Jim_IncrRefCount(i->result); @@ -5858,21 +5865,20 @@ Jim_CallFrame *Jim_GetCallFrameByLevel(Jim_Interp *interp, Jim_Obj *levelObjPtr) /* Similar to Jim_GetCallFrameByLevel() but the level is specified * as a relative integer like in the [info level ?level?] command. **/ -static Jim_CallFrame *JimGetCallFrameByInteger(Jim_Interp *interp, Jim_Obj *levelObjPtr) +static Jim_CallFrame *JimGetCallFrameByInteger(Jim_Interp *interp, long level) { - long level; Jim_CallFrame *framePtr; - if (Jim_GetLong(interp, levelObjPtr, &level) == JIM_OK) { - if (level <= 0) { - /* Convert from a relative to an absolute level */ - level = interp->framePtr->level + level; - } + if (level == 0) { + return interp->framePtr; + } - if (level == 0) { - return interp->topFramePtr; - } + if (level < 0) { + /* Convert from a relative to an absolute level */ + level = interp->framePtr->level + level; + } + if (level > 0) { /* Lookup */ for (framePtr = interp->framePtr; framePtr; framePtr = framePtr->parent) { if (framePtr->level == level) { @@ -5880,11 +5886,34 @@ static Jim_CallFrame *JimGetCallFrameByInteger(Jim_Interp *interp, Jim_Obj *leve } } } + return NULL; +} - Jim_SetResultFormatted(interp, "bad level \"%#s\"", levelObjPtr); +static Jim_EvalFrame *JimGetEvalFrameByInteger(Jim_Interp *interp, long level) +{ + Jim_EvalFrame *evalFrame; + + if (level == 0) { + return interp->evalFrame; + } + + if (level < 0) { + /* Convert from a relative to an absolute level */ + level = interp->evalFrame->level + level; + } + + if (level > 0) { + /* Lookup */ + for (evalFrame = interp->evalFrame; evalFrame; evalFrame = evalFrame->parent) { + if (evalFrame->level == level) { + return evalFrame; + } + } + } return NULL; } + static void JimResetStackTrace(Jim_Interp *interp) { Jim_DecrRefCount(interp, interp->stackTrace); @@ -10658,12 +10687,36 @@ static int JimUnknown(Jim_Interp *interp, int argc, Jim_Obj *const *argv) return retcode; } +static void JimPushEvalFrame(Jim_Interp *interp, Jim_EvalFrame *frame) +{ + memset(frame, 0, sizeof(*frame)); + frame->parent = interp->evalFrame; + frame->level = frame->parent->level + 1; + frame->type = "unknown"; + frame->callFrameLevel = interp->framePtr->level; + frame->scriptObj = interp->currentScriptObj; + interp->evalFrame = frame; +#if 0 + if (frame->scriptObj) { + printf("script: %.*s\n", 20, Jim_String(frame->scriptObj)); + } +#endif +} + +static void JimPopEvalFrame(Jim_Interp *interp) +{ + interp->evalFrame = interp->evalFrame->parent; +} + static int JimInvokeCommand(Jim_Interp *interp, int objc, Jim_Obj *const *objv) { int retcode; Jim_Cmd *cmdPtr; void *prevPrivData; Jim_Obj *tailcallObj = NULL; + int prev_argc; + Jim_Obj * const *prev_argv; + Jim_EvalFrame frame; #if 0 printf("invoke"); @@ -10687,9 +10740,29 @@ static int JimInvokeCommand(Jim_Interp *interp, int objc, Jim_Obj *const *objv) } interp->evalDepth++; prevPrivData = interp->cmdPrivData; + /* XXX We should consider creating a struct here (on the stack) with a back pointer + * so that the entire call chain can be walked. This would allow 'info frame' to walk + * the full call chain, not just call frames + */ + prev_argc = interp->argc; + prev_argv = interp->argv; + + JimPushEvalFrame(interp, &frame); tailcall: + interp->argc = objc; + interp->argv = objv; + + if (cmdPtr->isproc) { + frame.type = "proc"; + } + else { + frame.type = "cmd"; + } + frame.argc = objc; + frame.argv = objv; + if (!interp->traceCmdObj || (retcode = JimTraceCallback(interp, "cmd", objc, objv)) == JIM_OK) { /* Call it -- Make sure result is an empty object. */ @@ -10729,9 +10802,14 @@ tailcall: interp->cmdPrivData = prevPrivData; interp->evalDepth--; + interp->argc = prev_argc; + interp->argv = prev_argv; + out: JimDecrCmdRefCount(interp, cmdPtr); + JimPopEvalFrame(interp); + if (interp->framePtr->tailcallObj) { /* We might have skipped invoking a tailcall, perhaps because of an error * in defer handling so cleanup now @@ -11313,16 +11391,17 @@ int Jim_EvalNamespace(Jim_Interp *interp, Jim_Obj *scriptObj, Jim_Obj *nsObj) { Jim_CallFrame *callFramePtr; int retcode; + ScriptObj *script = JimGetScript(interp, scriptObj); /* Create a new callframe */ callFramePtr = JimCreateCallFrame(interp, interp->framePtr, nsObj); - callFramePtr->argv = &interp->emptyObj; - callFramePtr->argc = 0; + callFramePtr->argv = interp->argv; + callFramePtr->argc = interp->argc; callFramePtr->procArgsObjPtr = NULL; callFramePtr->procBodyObjPtr = scriptObj; callFramePtr->staticVars = NULL; - callFramePtr->fileNameObj = interp->emptyObj; - callFramePtr->line = 0; + callFramePtr->fileNameObj = script->fileNameObj; + callFramePtr->line = script->linenr; Jim_IncrRefCount(scriptObj); interp->framePtr = callFramePtr; @@ -11435,6 +11514,8 @@ static int JimCallProcedure(Jim_Interp *interp, Jim_Cmd *cmd, int argc, Jim_Obj } } + interp->evalFrame->cmd = cmd; + if (interp->traceCmdObj == NULL || (retcode = JimTraceCallback(interp, "proc", argc, argv)) == JIM_OK) { /* Eval the body */ @@ -11463,6 +11544,8 @@ badargset: Jim_IncrRefCount(interp->errorProc); } + interp->evalFrame->cmd = NULL; + return retcode; } @@ -11862,34 +11945,68 @@ static Jim_Obj *JimVariablesList(Jim_Interp *interp, Jim_Obj *patternObjPtr, int } } -static int JimInfoLevel(Jim_Interp *interp, Jim_Obj *levelObjPtr, - Jim_Obj **objPtrPtr, int info_level_cmd) +static int JimInfoLevel(Jim_Interp *interp, Jim_Obj *levelObjPtr, Jim_Obj **objPtrPtr) { - Jim_CallFrame *targetCallFrame; + long level; - targetCallFrame = JimGetCallFrameByInteger(interp, levelObjPtr); - if (targetCallFrame == NULL) { - return JIM_ERR; - } - /* No proc call at toplevel callframe */ - if (targetCallFrame == interp->topFramePtr) { - Jim_SetResultFormatted(interp, "bad level \"%#s\"", levelObjPtr); - return JIM_ERR; - } - if (info_level_cmd) { - *objPtrPtr = Jim_NewListObj(interp, targetCallFrame->argv, targetCallFrame->argc); + if (Jim_GetLong(interp, levelObjPtr, &level) == JIM_OK) { + Jim_CallFrame *targetCallFrame = JimGetCallFrameByInteger(interp, level); + if (targetCallFrame && targetCallFrame != interp->topFramePtr) { + *objPtrPtr = Jim_NewListObj(interp, targetCallFrame->argv, targetCallFrame->argc); + return JIM_OK; + } } - else { - Jim_Obj *listObj = Jim_NewListObj(interp, NULL, 0); + Jim_SetResultFormatted(interp, "bad level \"%#s\"", levelObjPtr); + return JIM_ERR; +} + +static int JimInfoFrame(Jim_Interp *interp, Jim_Obj *levelObjPtr, Jim_Obj **objPtrPtr) +{ + long level; + + if (Jim_GetLong(interp, levelObjPtr, &level) == JIM_OK) { + Jim_EvalFrame *targetEvalFrame = JimGetEvalFrameByInteger(interp, level); + if (targetEvalFrame) { + Jim_Obj *listObj = Jim_NewListObj(interp, NULL, 0); + int linenr; + Jim_Obj *fileNameObj; + Jim_Obj *cmdObj; + /*Jim_EvalFrame *procEvalFrame;*/ + + Jim_ListAppendElement(interp, listObj, Jim_NewStringObj(interp, "type", -1)); + Jim_ListAppendElement(interp, listObj, Jim_NewStringObj(interp, "source", -1)); + if (targetEvalFrame->scriptObj) { + ScriptObj *script = JimGetScript(interp, targetEvalFrame->scriptObj); + linenr = script->linenr; + fileNameObj = script->fileNameObj; + Jim_ListAppendElement(interp, listObj, Jim_NewStringObj(interp, "line", -1)); + Jim_ListAppendElement(interp, listObj, Jim_NewIntObj(interp, linenr)); + Jim_ListAppendElement(interp, listObj, Jim_NewStringObj(interp, "file", -1)); + Jim_ListAppendElement(interp, listObj, fileNameObj); + } + cmdObj = Jim_NewListObj(interp, targetEvalFrame->argv, targetEvalFrame->argc); + + Jim_ListAppendElement(interp, listObj, Jim_NewStringObj(interp, "cmd", -1)); + Jim_ListAppendElement(interp, listObj, cmdObj); + /* Look in parent frames for a proc name */ + Jim_EvalFrame *p; + for (p = targetEvalFrame->parent; p ; p = p->parent) { + if (p->cmd && p->cmd->isproc) { + Jim_ListAppendElement(interp, listObj, Jim_NewStringObj(interp, "proc", -1)); + Jim_ListAppendElement(interp, listObj, p->cmd->cmdNameObj); + break; + } + } + Jim_ListAppendElement(interp, listObj, Jim_NewStringObj(interp, "level", -1)); + Jim_ListAppendElement(interp, listObj, Jim_NewIntObj(interp, interp->framePtr->level - targetEvalFrame->callFrameLevel)); - Jim_ListAppendElement(interp, listObj, targetCallFrame->argv[0]); - Jim_ListAppendElement(interp, listObj, targetCallFrame->fileNameObj); - Jim_ListAppendElement(interp, listObj, Jim_NewIntObj(interp, targetCallFrame->line)); - *objPtrPtr = listObj; + *objPtrPtr = listObj; + return JIM_OK; + } } - return JIM_OK; + Jim_SetResultFormatted(interp, "bad level \"%#s\"", levelObjPtr); + return JIM_ERR; } - /* ----------------------------------------------------------------------------- * Core commands * ---------------------------------------------------------------------------*/ @@ -15457,14 +15574,32 @@ static int Jim_InfoCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *arg break; case INFO_LEVEL: - case INFO_FRAME: switch (argc) { case 2: Jim_SetResultInt(interp, interp->framePtr->level); break; case 3: - if (JimInfoLevel(interp, argv[2], &objPtr, cmd == INFO_LEVEL) != JIM_OK) { + if (JimInfoLevel(interp, argv[2], &objPtr) != JIM_OK) { + return JIM_ERR; + } + Jim_SetResult(interp, objPtr); + break; + + default: + Jim_WrongNumArgs(interp, 2, argv, "?levelNum?"); + return JIM_ERR; + } + break; + + case INFO_FRAME: + switch (argc) { + case 2: + Jim_SetResultInt(interp, interp->evalFrame->level); + break; + + case 3: + if (JimInfoFrame(interp, argv[2], &objPtr) != JIM_OK) { return JIM_ERR; } Jim_SetResult(interp, objPtr); @@ -446,6 +446,18 @@ typedef struct Jim_CallFrame { struct Jim_Cmd *tailcallCmd; /* Resolved command for pending tailcall invocation */ } Jim_CallFrame; +/* Evaluation frame */ +typedef struct Jim_EvalFrame { + const char *type; /* "cmd", "source", etc. */ + int level; /* Level of this evaluation frame. 0 = global */ + int callFrameLevel; /* corresponding call frame level */ + struct Jim_Cmd *cmd; /* The currently executing command */ + struct Jim_EvalFrame *parent; /* The parent frame or NULL if at top */ + Jim_Obj *const *argv; /* object vector of the current command . */ + int argc; /* number of args */ + Jim_Obj *scriptObj; +} Jim_EvalFrame; + /* The var structure. It just holds the pointer of the referenced * object. If linkFramePtr is not NULL the variable is a link * to a variable of name stored in objPtr living in the given callframe @@ -488,6 +500,7 @@ typedef struct Jim_Cmd { int inUse; /* Reference count */ int isproc; /* Is this a procedure? */ struct Jim_Cmd *prevCmd; /* Previous command defn if cmd created 'local' */ + Jim_Obj *cmdNameObj; /* The fully resolved command name - just a pointer, not a reference */ union { struct { /* native (C) command */ @@ -555,6 +568,10 @@ typedef struct Jim_Interp { Jim_Obj *liveList; /* Linked list of all the live objects. */ Jim_Obj *freeList; /* Linked list of all the unused objects. */ Jim_Obj *currentScriptObj; /* Script currently in execution. */ + Jim_EvalFrame topEvalFrame; /* dummy top evaluation frame */ + Jim_EvalFrame *evalFrame; /* evaluation stack */ + int argc; + Jim_Obj * const *argv; Jim_Obj *nullScriptObj; /* script representation of an empty string */ Jim_Obj *emptyObj; /* Shared empty string object. */ Jim_Obj *trueObj; /* Shared true int object. */ diff --git a/jim_tcl.txt b/jim_tcl.txt index d74c1f8..097e36a 100644 --- a/jim_tcl.txt +++ b/jim_tcl.txt @@ -58,6 +58,7 @@ Changes between 0.81 and 0.82 2. TIP 603, `aio stat` is now supported to stat a file handle 3. Add support for `socket -async` 4. The handles created by `socket pty` now make the replica name available via 'filename' +5. `info frame` now returns a (largely) Tcl-compatible dictionary, and supports 'info frame 0' Changes between 0.80 and 0.81 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2876,6 +2877,7 @@ The legal +'option'+'s (which may be abbreviated) are: otherwise. +*info frame* ?'number'?+:: + TBD: Update for new Tcl-compatible dictionary format - type, line, file, cmd, proc, level. If +'number'+ is not specified, this command returns a number which is the same result as `info level` - the current stack frame level. If +'number'+ is specified, then the result is a list consisting of the procedure, @@ -378,7 +378,9 @@ proc debugger::_db {type file line result name arglist} { # Build the active stacktrace set s(stacktrace) {} foreach level [range 1 [info level]] { - lassign [info frame $level] p f l + set frame [info frame $level] + set f [dict get $frame file] + set l [dict get $frame line] lassign [info level $level] p pargs lappend s(stacktrace) [list $f $l $p $pargs] } @@ -38,9 +38,29 @@ proc function {value} { # (deepest level first) proc stacktrace {{skip 0}} { set trace {} - incr skip - foreach level [range $skip [info level]] { - lappend trace {*}[info frame -$level] + # Need to skip info frame 0 and this (stacktrace) level + incr skip 2 + loop level $skip [info level]+1 { + set frame [info frame -$level] + lappend trace [lindex [dict get $frame cmd] 0] [dict get $frame file] [dict get $frame line] + } + return $trace +} +proc stacktrace {{skip 0}} { + set trace {} + # skip the internal frames + incr skip 1 + set last 0 + loop level $skip [info frame]+1 { + set frame [info frame -$level] + set file [dict get $frame file] + set line [dict get $frame line] + set lev [dict get $frame level] + if {$lev != $last && $lev > $skip} { + set proc [lindex [dict get $frame cmd] 0] + lappend trace $proc $file $line + } + set last $lev } return $trace } diff --git a/tests/apply.test b/tests/apply.test index 504b4ae..81d3833 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -128,11 +128,11 @@ test apply-8.10 {default values} { } {{args {}} {x 1} {y 3}} test apply-9.1 {tailcall within apply} { - proc p {y frame} { - list [expr {$y * 2}] [expr {$frame - [info frame]}] + proc p {y level} { + list [expr {$y * 2}] [expr {$level - [info level]}] } apply {{x} { - tailcall p $x [info frame] + tailcall p $x [info level] notreached }} {4} } {8 0} diff --git a/tests/infoframe.test b/tests/infoframe.test index 0bfd7a9..9490589 100644 --- a/tests/infoframe.test +++ b/tests/infoframe.test @@ -2,10 +2,10 @@ source [file dirname [info script]]/testing.tcl needs constraint jim proc a {n} { if {$n eq "trace"} { - basename-stacktrace [stacktrace] - } else { - basename-stacktrace [info frame $n] + # strip the frame levels for test and uplevel + return [basename-stacktrace [lrange [stacktrace] 0 end-6]] } + set frame [info frame $n]; list [dict getdef $frame proc {}] [file tail [dict get $frame file]] [dict get $frame line] } proc b {n} { @@ -18,20 +18,24 @@ proc c {n} { # --- Don't change line numbers above -test info-frame-1.1 "Current proc" { +test info-frame-1.1 "Current command" { c 0 -} {a infoframe.test 12} +} {a infoframe.test 8} -test info-frame-1.2 "Caller" { +test info-frame-1.2 "Current Proc" { c -1 -} {b infoframe.test 16} +} {b infoframe.test 12} -test info-frame-1.3 "Caller of Caller" { +test info-frame-1.3 "Caller" { c -2 -} {c infoframe.test 30} +} {c infoframe.test 16} + +test info-frame-1.4 "Caller of Caller" { + c -3 +} {test infoframe.test 34} test stacktrace-1.1 "Full stack trace" { c trace -} {a infoframe.test 12 b infoframe.test 16 c infoframe.test 34} +} {a infoframe.test 12 b infoframe.test 16 c infoframe.test 38} testreport |