diff options
| -rw-r--r-- | doc/jim_tcl.txt | 28 | ||||
| -rw-r--r-- | jim.c | 17 | ||||
| -rw-r--r-- | jim.h.in | 2 | ||||
| -rw-r--r-- | tclcompat.tcl | 2 | ||||
| -rw-r--r-- | tests/tailcall.test | 50 | ||||
| -rw-r--r-- | tests/tree.test | 13 | ||||
| -rw-r--r-- | tree.tcl | 34 |
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'+ @@ -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) { @@ -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 @@ -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 |