Tcl-compatible 'info frame'

Returns a dictionary with file, line, cmd, (possibly) proc and level.
And support 'info frame 0' for the current command.

Note that now all evaluation frames are captured, not just call frames.

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

7 files changed, 236 insertions, 56 deletions

diff --git a/jim.c b/jim.c
index 36a9243..1e07d28 100644
--- a/jim.c
+++ b/jim.c
@@ -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);
diff --git a/jim.h b/jim.h
index 2ce3312..763c456 100644
--- a/jim.h
+++ b/jim.h
@@ -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,
diff --git a/jimdb b/jimdb
index 929dac2..f72974d 100755
--- a/jimdb
+++ b/jimdb
@@ -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]
             }
diff --git a/stdlib.tcl b/stdlib.tcl
index 37a8007..01d73c0 100644
--- a/stdlib.tcl
+++ b/stdlib.tcl
@@ -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