jim: info frame improvements

always include 'proc' even if introspection disabled
correctly set 'proc' at the eval frame level that is currently running
in the given proc. This makes it easier to produce an accurate level stacktrace
even across uplevel, etc.

Update stacktrace to use the new info frame.

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

5 files changed, 93 insertions, 57 deletions

diff --git a/jim.c b/jim.c
index 9059f48..c752312 100644
--- a/jim.c
+++ b/jim.c
@@ -12017,23 +12017,44 @@ static int JimInfoFrame(Jim_Interp *interp, Jim_Obj *levelObjPtr, Jim_Obj **objP
             }
 #ifndef JIM_NO_INTROSPECTION
             {
-                Jim_Obj *cmdObj;
-                /* Omit the command and proc */
-                cmdObj = Jim_NewListObj(interp, targetEvalFrame->argv, targetEvalFrame->argc);
+                Jim_Obj *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);
+            }
+#endif
+            /* Now determine if this eval frame has a proc caller */
+            {
+                /* If the target eval frame has proc call frame level >= the previous one
+                 * we don't set 'proc' (it will be set on the previous one)
+                 * So first determine if this needs 'proc'
+                 */
+                Jim_EvalFrame *e, *p = NULL;
+                for (e = interp->evalFrame; e; e = e->parent) {
+                    if (e == targetEvalFrame) {
                         break;
                     }
+                    if (!p || e->callFrameLevel != p->callFrameLevel) {
+                        p = e;
+                    }
+                    else {
+                        p = NULL;
+                    }
+                }
+                if (!p || e->callFrameLevel < p->callFrameLevel) {
+                    /* Find the first proc above this level */
+                    for (e = targetEvalFrame->parent; e; e = e->parent) {
+                        if (e->cmd && e->cmd->isproc) {
+                            /* apply and namespace eval won't provide cmdNameObj */
+                            if (e->cmd->cmdNameObj) {
+                                Jim_ListAppendElement(interp, listObj, Jim_NewStringObj(interp, "proc", -1));
+                                Jim_ListAppendElement(interp, listObj, e->cmd->cmdNameObj);
+                            }
+                            break;
+                        }
+                    }
                 }
             }
-#endif
             Jim_ListAppendElement(interp, listObj, Jim_NewStringObj(interp, "level", -1));
             Jim_ListAppendElement(interp, listObj, Jim_NewIntObj(interp, interp->framePtr->level - targetEvalFrame->callFrameLevel));
 
diff --git a/regtest.tcl b/regtest.tcl
index b0cb70b..a9ee5eb 100644
--- a/regtest.tcl
+++ b/regtest.tcl
@@ -384,6 +384,9 @@ foreach i $chars1 {
 alarm 0
 puts "TEST 54 PASSED"
 
+# info frame should work even if in an anonymous proc
+apply {{} {info frame 0}}
+puts "TEST 55 PASSED"
 
 # TAKE THE FOLLOWING puts AS LAST LINE
 
diff --git a/stdlib.tcl b/stdlib.tcl
index cd82419..804a499 100644
--- a/stdlib.tcl
+++ b/stdlib.tcl
@@ -37,32 +37,14 @@ proc function {value} {
 # with 3 entries for each stack frame (proc),
 # (deepest level first)
 proc stacktrace {{skip 0}} {
-	set trace {}
-	# Need to skip info frame 0 and this (stacktrace) level
-	incr skip 2
-	loop level $skip [info level]+1 {
+	set frames {}
+	loop level 2 [info frame]+1 {
 		set frame [info frame -$level]
-		lappend trace [lindex [dict getdef $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
+		if {$frame(level) > $skip && [dict exists $frame proc]} {
+			lappend frames $frame(proc) $frame(file) $frame(line)
 		}
-		set last $lev
 	}
-	return $trace
+	return $frames
 }
 
 # Returns a human-readable version of a stack trace
diff --git a/tcltest.tcl b/tcltest.tcl
index a95f665..2b8d3d8 100644
--- a/tcltest.tcl
+++ b/tcltest.tcl
@@ -73,6 +73,20 @@ proc skiptest {{msg {}}} {
 	exit 0
 }
 
+# Takes a stacktrace and applies [file tail] to the filenames.
+# This allows stacktrace tests to be run from a directory other than the source directory.
+# Also convert proc name ::a into a for compatibility between Tcl and Jim
+proc basename-stacktrace {stacktrace} {
+	set result {}
+	foreach {p f l} $stacktrace {
+		if {[string match ::* $p]} {
+			set p [string range $p 2 end]
+		}
+		lappend result $p [file tail $f] $l
+	}
+	return $result
+}
+
 # If tcl, just use tcltest
 if {[catch {info version}]} {
 	package require Tcl 8.5
@@ -87,6 +101,29 @@ if {[catch {info version}]} {
 	proc testreport {} {
 		::tcltest::cleanupTests
 	}
+	proc stacktrace {{skip 0}} {
+		set trace {}
+		# Need to skip info frame 0 and this (stacktrace) level
+		incr skip 1
+		set maxlevel [info frame]
+		for {set level $skip} {$level < $maxlevel} {incr level} {
+			set frame [info frame -$level]
+			if {[dict get $frame type] eq "source" && [dict exists $frame proc]} {
+				set proc [dict get $frame proc]
+				# make it look like it is running under Jim tcltest
+				if {$proc eq "::tcltest::RunTest"} {
+					set proc test
+				} else {
+					set proc [string range $proc 2 end]
+				}
+				lappend trace $proc [dict get $frame file] [dict get $frame line]
+				if {$proc eq "test"} {
+					break
+				}
+			}
+		}
+		return $trace
+	}
 	return
 }
 
@@ -195,16 +232,6 @@ proc bytestring {x} {
 	return $x
 }
 
-# Takes a stacktrace and applies [file tail] to the filenames.
-# This allows stacktrace tests to be run from a directory other than the source directory.
-proc basename-stacktrace {stacktrace} {
-	set result {}
-	foreach {p f l} $stacktrace {
-		lappend result $p [file tail $f] $l
-	}
-	return $result
-}
-
 # Takes a list of {filename line} and returns {basename line}
 proc basename-source {list} {
 	list [file tail [lindex $list 0]] [lindex $list 1]
diff --git a/tests/infoframe.test b/tests/infoframe.test
index 9490589..e8544b1 100644
--- a/tests/infoframe.test
+++ b/tests/infoframe.test
@@ -1,11 +1,14 @@
 source [file dirname [info script]]/testing.tcl
-needs constraint jim
+
 proc a {n} {
 	if {$n eq "trace"} {
-		# strip the frame levels for test and uplevel
-		return [basename-stacktrace [lrange [stacktrace] 0 end-6]]
+		return [basename-stacktrace [stacktrace]]
+	}
+	set frame [info frame $n]
+	if {![dict exists $frame proc]} {
+		dict set frame proc {}
 	}
-	set frame [info frame $n]; list [dict getdef $frame proc {}] [file tail [dict get $frame file]] [dict get $frame line]
+	basename-stacktrace [list [dict get $frame proc] [file tail [dict get $frame file]] [dict get $frame line]]
 }
 
 proc b {n} {
@@ -18,24 +21,24 @@ proc c {n} {
 
 # --- Don't change line numbers above
 
-test info-frame-1.1 "Current command" {
+test info-frame-1.1 {Current command} -body {
 	c 0
-} {a infoframe.test 8}
+} -result {a infoframe.test 7}
 
-test info-frame-1.2 "Current Proc" {
+test info-frame-1.2 {Current Proc} -body {
 	c -1
-} {b infoframe.test 12}
+} -result {b infoframe.test 15}
 
-test info-frame-1.3 "Caller" {
+test info-frame-1.3 Caller -body {
 	c -2
-} {c infoframe.test 16}
+} -result {c infoframe.test 19}
 
-test info-frame-1.4 "Caller of Caller" {
+test info-frame-1.4 {Caller of Caller} -body {
 	c -3
-} {test infoframe.test 34}
+} -result {test infoframe.test 37}
 
-test stacktrace-1.1 "Full stack trace" {
+test stacktrace-1.1 {Full stack trace} -body {
 	c trace
-} {a infoframe.test 12 b infoframe.test 16 c infoframe.test 38}
+} -result {a infoframe.test 5 b infoframe.test 15 c infoframe.test 19 test infoframe.test 41}
 
 testreport