Improvements to tailcall

Add tests and documentation
Make tailcall work within 'try'
Fix tailcall interaction with uplevel
Use tailcall for dispatch in tree.tcl
Also some related improvements in tree.tcl

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

7 files changed, 104 insertions, 42 deletions

diff --git a/doc/jim_tcl.txt b/doc/jim_tcl.txt
index 9c17aa7..c826221 100644
--- a/doc/jim_tcl.txt
+++ b/doc/jim_tcl.txt
@@ -52,9 +52,10 @@ The major differences are:
 15. Must better error reporting. 'info stacktrace' as a replacement for 'errorInfo', 'errorCode'
 16. Support for "static" variables in procedures
 17. Significantly faster for many scripts/operations
-18. Command pipelines via open "|..." are not supported (but see 'exec' and 'socket pipe')
-19. Variable traces are not supported
-20. The history command is not supported
+18. Support for tail-call optimisation, 'tailcall'
+19. Command pipelines via open "|..." are not supported (but see 'exec' and 'socket pipe')
+20. Variable traces are not supported
+21. The history command is not supported
 
 CHANGES
 -------
@@ -3461,6 +3462,27 @@ will return 1, and
 
 will return 3.
 
+tailcall
+~~~~~~~~
++*tailcall* 'cmd ?arg...?'+
+
+The 'tailcall' command provides an optimised way of invoking a command whilst replacing
+the current call frame. This is similar to 'exec' in Bourne Shell.
+
+The following are identical except the first immediately replaces the current call frame.
+
+  tailcall a b c
+
+  return [uplevel 1 a b c]
+
+'tailcall' is useful for a dispatch mechanism:
+
+  proc a {cmd args} {
+	tailcall sub_$cmd {*}$args
+  }
+  proc sub_cmd1 ...
+  proc sub_cmd2 ...
+
 tell
 ~~~~
 +*tell* 'fileId'+
diff --git a/jim.c b/jim.c
index f13a4b6..90f55ad 100644
--- a/jim.c
+++ b/jim.c
@@ -4398,7 +4398,6 @@ Jim_Interp *Jim_CreateInterp(void)
     i->lastCollectTime = time(NULL);
     i->freeFramesList = NULL;
     i->prngState = NULL;
-    i->evalRetcodeLevel = -1;
     i->id = 0;
     i->sigmask = 0;
     i->signal_level = 0;
@@ -9284,17 +9283,11 @@ int JimCallProcedure(Jim_Interp *interp, Jim_Cmd *cmd, int argc,
         JimFreeCallFrame(interp, callFramePtr, JIM_FCF_NOHT);
     }
     /* Handle the JIM_EVAL return code */
-    if (retcode == JIM_EVAL && interp->evalRetcodeLevel != interp->numLevels) {
-        int savedLevel = interp->evalRetcodeLevel;
-
-        interp->evalRetcodeLevel = interp->numLevels;
-        while (retcode == JIM_EVAL) {
-            Jim_Obj *resultScriptObjPtr = Jim_GetResult(interp);
-            Jim_IncrRefCount(resultScriptObjPtr);
-            retcode = Jim_EvalObj(interp, resultScriptObjPtr);
-            Jim_DecrRefCount(interp, resultScriptObjPtr);
-        }
-        interp->evalRetcodeLevel = savedLevel;
+    while (retcode == JIM_EVAL) {
+        Jim_Obj *resultScriptObjPtr = Jim_GetResult(interp);
+        Jim_IncrRefCount(resultScriptObjPtr);
+        retcode = Jim_EvalObj(interp, resultScriptObjPtr);
+        Jim_DecrRefCount(interp, resultScriptObjPtr);
     }
     /* Handle the JIM_RETURN return code */
     if (retcode == JIM_RETURN) {
diff --git a/jim.h.in b/jim.h.in
index a02a045..ebe981a 100644
--- a/jim.h.in
+++ b/jim.h.in
@@ -531,8 +531,6 @@ typedef struct Jim_Interp {
     Jim_Obj *unknown; /* Unknown command cache */
     int unknown_called; /* The unknown command has been invoked */
     int errorFlag; /* Set if an error occurred during execution. */
-    int evalRetcodeLevel; /* Level where the last return with code JIM_EVAL
-                             happened. */
     void *cmdPrivData; /* Used to pass the private data pointer to
                   a command. It is set to what the user specified
                   via Jim_CreateCommand(). */
diff --git a/tclcompat.tcl b/tclcompat.tcl
index 58dee97..0c6c550 100644
--- a/tclcompat.tcl
+++ b/tclcompat.tcl
@@ -164,7 +164,7 @@ proc try {args} {
 		return -code error {wrong # args: should be "try ?options? script ?argument ...?"}
 	}
 	set args [lassign $args script]
-	set code [catch {*}$catchopts [list uplevel 1 $script] msg opts]
+	set code [catch -eval {*}$catchopts [list uplevel 1 $script] msg opts]
 
 	set handled 0
 
diff --git a/tests/tailcall.test b/tests/tailcall.test
new file mode 100644
index 0000000..eb097e5
--- /dev/null
+++ b/tests/tailcall.test
@@ -0,0 +1,50 @@
+source testing.tcl
+
+test tailcall-1.1 {Basic tailcall} {
+	# Demo -- a tail-recursive factorial function
+	proc fac {x {val 1}} {
+		if {$x <= 2} {
+			expr {$x * $val}
+		} else {
+			tailcall fac [expr {$x -1}] [expr {$x * $val}]
+		}
+	}
+	fac 10
+} {3628800}
+
+test tailcall-1.2 {Tailcall in try} {
+	set x 0
+	proc a {} { upvar x x; incr x }
+	proc b {} { upvar x x; incr x 4; try { tailcall a } finally { incr x 8 }}
+	b
+	set x
+} {13}
+
+test tailcall-1.3 {Tailcall does return} {
+	set x 0
+	proc a {} { upvar x x; incr x }
+	proc b {} { upvar x x; incr x 4; tailcall a; incr x 8}
+	b
+	set x
+} {5}
+
+test tailcall-1.4 {uplevel tailcall} {
+	proc a {} { set ::y [info level] }
+	proc b {} { set ::x [info level]; uplevel 1 tailcall a}
+	b
+	list $x $y
+} {1 1}
+
+test tailcall-1.5 {interaction of uplevel and tailcall} {
+	proc a {cmd} {
+		tailcall $cmd
+	}
+	proc b {} {
+		lappend result [uplevel 1 a c]
+		lappend result [uplevel 1 a c]
+	}
+	proc c {} {
+		return c
+	}
+	a b
+} {c c}
diff --git a/tests/tree.test b/tests/tree.test
index e5b539a..d9aa389 100644
--- a/tests/tree.test
+++ b/tests/tree.test
@@ -3,6 +3,10 @@ package require tree
 
 section "tree"
 
+proc dputs {msg} {
+	#puts $msg
+}
+
 test tree-1.1 "Create tree" {
 	tree create pt
 	return 1
@@ -76,15 +80,15 @@ test tree-2.0 "Add more nodes" {
 
 test tree-2.1 "walk dfs" {
 	set result {}
-	#puts ""
+	dputs ""
 	pt walk root dfs {action n} {
 		set indent [string repeat "  " [pt depth $n]]
 		if {$action == "enter"} {
 			lappend result [pt get $n name]
-			#puts "$indent[pt get $n name]"
+			dputs "$indent[pt get $n name]"
 		}
 	}
-	#puts ""
+	dputs ""
 	set result
 } {rootnode childnode1 childnode2 n.c4 n.c5 n.c5.c6 root.c2 root.c3}
 
@@ -109,6 +113,3 @@ test tree-2.3 "walk bfs" {
 } {rootnode childnode1 root.c2 root.c3 childnode2 n.c4 n.c5 n.c5.c6}
 
 tree destroy pt
-
-collect
-#pt set root name value
diff --git a/tree.tcl b/tree.tcl
index c534f85..6b961c7 100644
--- a/tree.tcl
+++ b/tree.tcl
@@ -70,12 +70,12 @@ proc tree {action handle} {
 	# and other nodes are automatically named "node1", "node2", etc.
 
 	if {$action eq "destroy"} {
-		$handle destroy
+		$handle _destroy
 		rename $handle ""
 		return
 	} elseif {$action eq "create"} {
 		# Create the root node
-		foreach {dummy rootref} [_tree_makenode ""] {}
+		lassign [_tree_makenode ""] dummy rootref
 
 		# Create the tree containing one node
 		set tree [dict create root $rootref]
@@ -85,26 +85,13 @@ proc tree {action handle} {
 
 		proc $handle {command args} {treeref} {
 			#puts "You invoked [list treehandle $command $args]"
-			uplevel 1 [list tree_$command $treeref {expand}$args]
+			tailcall tree_$command $treeref {*}$args
 		}
 	} else {
 		error "Usage: tree destroy|create handle"
 	}
 }
 
-# treehandle destroy
-#
-# Discards all the nodes
-#
-proc tree_destroy {treeref} {
-	set tree [getref $treeref]
-	foreach {nodename noderef} $tree {
-		set node [getref $noderef]
-		unset node
-	}
-	unset tree
-}
-
 # treehandle insert node ?index?
 #
 proc tree_insert {treeref node {index end}} {
@@ -112,7 +99,7 @@ proc tree_insert {treeref node {index end}} {
 	set parentref [_tree_getnoderef $treeref $node]
 
 	# Make a new node
-	foreach {childname childref} [_tree_makenode $parentref] {}
+	lassign [_tree_makenode $parentref] childname childref
 
 	# Add it to the list of children in the parent node
 	_tree_update_node $treeref $node parent {
@@ -210,7 +197,7 @@ proc tree_walk {treeref node type vars code} {
 	set n [_tree_getnode $treeref $node]
 
 	# set up vars
-	foreach {actionvar namevar} $vars {}
+	lassign $vars actionvar namevar
 
 	if {$type ne "child"} {
 		upvar $namevar name
@@ -256,6 +243,17 @@ proc tree_walk {treeref node type vars code} {
 # INTERNAL procedures below this point
 #
 
+# Discards all the nodes
+#
+proc tree__destroy {treeref} {
+	set tree [getref $treeref]
+	foreach {nodename noderef} $tree {
+		setref $noderef {}
+	}
+	setref $treeref {}
+}
+
+
 # Make a new child node of the parent
 #
 # Note that this does *not* add the node