# Commands covered: tailcall, atProcExit, coroutine, yield
#
# This file contains a collection of tests for experimental commands that are
# found in ::tcl::unsupported. The tests will migrate to normal test files
# if/when the commands find their way into the core.
#
# Copyright (c) 2008 by Miguel Sofer.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: unsupported.test,v 1.14 2008/10/14 16:35:44 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testnrelevels [llength [info commands testnrelevels]]
testConstraint atProcExit [llength [info commands ::tcl::unsupported::atProcExit]]
if {[namespace exists tcl::unsupported]} {
namespace eval tcl::unsupported namespace export *
namespace import tcl::unsupported::*
}
#
# The tests that risked blowing the C stack on failure have been removed: we
# can now actually measure using testnrelevels.
#
if {[testConstraint testnrelevels]} {
namespace eval testnre {
#
# [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels,
# cmdFrame level, callFrame level, tosPtr and callback depth
#
variable last [testnrelevels]
proc depthDiff {} {
variable last
set depth [testnrelevels]
set res {}
foreach t $depth l $last {
lappend res [expr {$t-$l}]
}
set last $depth
return $res
}
proc setabs {} {
uplevel 1 variable abs -[lindex [testnrelevels] 0]
}
variable body0 {
set x [depthDiff]
if {[incr i] > 10} {
variable abs
incr abs [lindex [testnrelevels] 0]
return [list [lrange $x 0 3] $abs]
}
}
proc makebody txt {
variable body0
return "$body0; $txt"
}
namespace export *
}
namespace import testnre::*
}
#
# Test atProcExit
#
test unsupported-A.1 {atProcExit works} -constraints {atProcExit} -setup {
variable x x y y
proc a {} {
variable x 0 y 0
atProcExit set ::x 1
set x 2
set y $x
set x 3
}
proc b {} a
} -body {
list [b] $x $y
} -cleanup {
unset x y
rename a {}
rename b {}
} -result {3 1 2}
test unsupported-A.2 {atProcExit} -constraints {atProcExit} -setup {
variable x x y x
proc a {} {
variable x 0 y 0
atProcExit set ::x 1
set x 2
set y $x
set x 3
}
} -body {
list [a] $x $y
} -cleanup {
unset x y
rename a {}
} -result {3 1 2}
test unsupported-A.3 {atProcExit} -constraints {atProcExit} -setup {
variable x x y y
proc a {} {
variable x 0 y 0
atProcExit lappend ::x 1
lappend x 2
atProcExit lappend ::x 3
lappend y $x
lappend x 4
return 5
}
} -body {
list [a] $x $y
} -cleanup {
unset x y
rename a {}
} -result {5 {0 2 4 3 1} {0 {0 2}}}
test unsupported-A.4 {atProcExit errors} -constraints {atProcExit} -setup {
variable x x y y
proc a {} {
variable x 0 y 0
atProcExit lappend ::x 1
lappend x 2
atProcExit lappend ::x 3
lappend y $x
lappend x 4
error foo
}
} -body {
list [a] $x $y
} -cleanup {
unset x y
rename a {}
} -returnCodes error -result foo
test unsupported-A.5 {atProcExit errors} -constraints {atProcExit} -setup {
variable x x y y
proc a {} {
variable x 0 y 0
atProcExit error foo
lappend x 2
atProcExit lappend ::x 3
lappend y $x
lappend x 4
return 5
}
} -body {
list [a] $x $y
} -cleanup {
unset x y
rename a {}
} -result {5 {0 2 4 3} {0 {0 2}}}
test unsupported-A.6 {atProcExit errors} -constraints {atProcExit} -setup {
variable x x y y
proc a {} {
variable x 0 y 0
atProcExit lappend ::x 1
lappend x 2
atProcExit error foo
lappend y $x
lappend x 4
return 5
}
} -body {
list [a] $x $y
} -cleanup {
unset x y
rename a {}
} -result {5 {0 2 4} {0 {0 2}}}
test unsupported-A.7 {atProcExit non-proc} -constraints {atProcExit} -body {
atProcExit set x 2
set x 1
} -cleanup {
unset -nocomplain x
} -match glob -result *atProcExit* -returnCodes error
test unsupported-A.8 {atProcExit and eval} -constraints {knownBug atProcExit} -setup {
proc a {} {
eval atProcExit lappend ::x 2
set ::x 1
}
} -body {
list [a] $::x
} -cleanup {
unset -nocomplain ::x
} -result {1 2}
test unsupported-A9 {atProcExit and uplevel} -constraints {knownBug atProcExit} -setup {
proc a {} {
uplevel 1 [list atProcExit set ::x 2]
set ::x 1
}
} -body {
list [a] $::x
} -cleanup {
unset -nocomplain ::x
} -result {1 2}
#
# Test tailcalls
#
test unsupported-T.0 {tailcall is constant space} -constraints testnrelevels -setup {
proc a i {
if {[incr i] > 10} {
return [depthDiff]
}
depthDiff
tailcall a $i
}
} -body {
a 0
} -cleanup {
rename a {}
} -result {0 0 0 0 0 0}
test unsupported-T.1 {tailcall} -body {
namespace eval a {
variable x *::a
proc xset {} {
set tmp {}
set ns {[namespace current]}
set level [info level]
for {set i 0} {$i <= [info level]} {incr i} {
uplevel #$i "set x $i$ns"
lappend tmp "$i [info level $i]"
}
lrange $tmp 1 end
}
proc foo {} {tailcall xset; set x noreach}
}
namespace eval b {
variable x *::b
proc xset args {error b::xset}
proc moo {} {set x 0; variable y [::a::foo]; set x}
}
variable x *::
proc xset args {error ::xset}
list [::b::moo] | $x $a::x $b::x | $::b::y
} -cleanup {
unset x
rename xset {}
namespace delete a b
} -result {1::b | 0:: *::a *::b | {{1 ::b::moo} {2 xset}}}
test unsupported-T.2 {tailcall in non-proc} -body {
namespace eval a [list tailcall set x 1]
} -match glob -result *tailcall* -returnCodes error
test unsupported-T.3 {tailcall falls off tebc} -body {
unset -nocomplain x
proc foo {} {tailcall set x 1}
list [catch foo msg] $msg [set x]
} -cleanup {
rename foo {}
unset x
} -result {0 1 1}
test unsupported-T.4 {tailcall falls off tebc} -body {
set x 2
proc foo {} {tailcall set x 1}
foo
set x
} -cleanup {
rename foo {}
unset x
} -result 1
test unsupported-T.5 {tailcall falls off tebc} -body {
set x 2
namespace eval bar {
variable x 3
proc foo {} {tailcall set x 1}
}
bar::foo
list $x $bar::x
} -cleanup {
unset x
namespace delete bar
} -result {1 3}
test unsupported-T.6 {tailcall does remove callframes} -body {
proc foo {} {info level}
proc moo {} {tailcall foo}
proc boo {} {expr {[moo] - [info level]}}
boo
} -cleanup {
rename foo {}
rename moo {}
rename boo {}
} -result 1
test unsupported-T.7 {tailcall does return} -setup {
namespace eval ::foo {
variable res {}
proc a {} {
variable res
append res a
tailcall set x 1
append res a
}
proc b {} {
variable res
append res b
a
append res b
}
proc c {} {
variable res
append res c
b
append res c
}
}
} -body {
namespace eval ::foo c
} -cleanup {
namespace delete ::foo
} -result cbabc
test unsupported-T.8 {tailcall tailcall} -setup {
namespace eval ::foo {
variable res {}
proc a {} {
variable res
append res a
tailcall tailcall set x 1
append res a
}
proc b {} {
variable res
append res b
a
append res b
}
proc c {} {
variable res
append res c
b
append res c
}
}
} -body {
namespace eval ::foo c
} -cleanup {
namespace delete ::foo
} -match glob -result *tailcall* -returnCodes error
test unsupported-T.9 {tailcall factorial} -setup {
proc fact {n {b 1}} {
if {$n == 1} {
return $b
}
tailcall fact [expr {$n-1}] [expr {$n*$b}]
}
} -body {
list [fact 1] [fact 5] [fact 10] [fact 15]
} -cleanup {
rename fact {}
} -result {1 120 3628800 1307674368000}
test unsupported-T.10 {tailcall and eval} -constraints {knownBug atProcExit} -setup {
proc a {} {
eval [list tailcall lappend ::x 2]
set ::x 1
}
} -body {
list [a] $::x
} -cleanup {
unset -nocomplain ::x
} -result {1 2}
test unsupported-T.11 {tailcall and uplevel} -constraints {knownBug atProcExit} -setup {
proc a {} {
uplevel 1 [list tailcall set ::x 2]
set ::x 1
}
} -body {
list [a] $::x
} -cleanup {
unset -nocomplain ::x
} -result {1 2}
#
# Test both together
#
test unsupported-AT.1 {atProcExit and tailcall} -constraints {
atProcExit
} -setup {
variable x x y y
proc a {} {
variable x 0 y 0
atProcExit lappend ::x 1
lappend x 2
atProcExit lappend ::x 3
tailcall lappend ::x 6
lappend y $x
lappend x 4
return 5
}
} -body {
list [a] $x $y
} -cleanup {
unset x y
rename a {}
} -result {{0 2 3 1 6} {0 2 3 1 6} 0}
#
# Test coroutines
#
set lambda [list {{start 0} {stop 10}} {
# init
set i $start
set imax $stop
yield
while {$i < $imax} {
yield [expr {$i*$stop}]
incr i
}
}]
test unsupported-C.1.1 {coroutine basic} -setup {
coroutine foo ::apply $lambda
set res {}
} -body {
for {set k 1} {$k < 4} {incr k} {
lappend res [foo]
}
set res
} -cleanup {
rename foo {}
unset res
} -result {0 10 20}
test unsupported-C.1.2 {coroutine basic} -setup {
coroutine foo ::apply $lambda 2 8
set res {}
} -body {
for {set k 1} {$k < 4} {incr k} {
lappend res [foo]
}
set res
} -cleanup {
rename foo {}
unset res
} -result {16 24 32}
test unsupported-C.1.3 {yield returns new arg} -setup {
set body {
# init
set i $start
set imax $stop
yield
while {$i < $imax} {
set stop [yield [expr {$i*$stop}]]
incr i
}
}
coroutine foo ::apply [list {{start 2} {stop 10}} $body]
set res {}
} -body {
for {set k 1} {$k < 4} {incr k} {
lappend res [foo $k]
}
set res
} -cleanup {
rename foo {}
unset res
} -result {20 6 12}
test unsupported-C.1.4 {yield in nested proc} -setup {
proc moo {} {
upvar 1 i i stop stop
yield [expr {$i*$stop}]
}
set body {
# init
set i $start
set imax $stop
yield
while {$i < $imax} {
moo
incr i
}
}
coroutine foo ::apply [list {{start 0} {stop 10}} $body]
set res {}
} -body {
for {set k 1} {$k < 4} {incr k} {
lappend res [foo $k]
}
set res
} -cleanup {
rename foo {}
rename moo {}
unset body res
} -result {0 10 20}
test unsupported-C.1.5 {just yield} -body {
coroutine foo yield
list [foo] [catch foo msg] $msg
} -cleanup {
unset msg
} -result {{} 1 {invalid command name "foo"}}
test unsupported-C.1.6 {just yield} -body {
coroutine foo [list yield]
list [foo] [catch foo msg] $msg
} -cleanup {
unset msg
} -result {{} 1 {invalid command name "foo"}}
test unsupported-C.1.7 {yield in nested uplevel} -setup {
set body {
# init
set i $start
set imax $stop
yield
while {$i < $imax} {
uplevel 0 [list yield [expr {$i*$stop}]]
incr i
}
}
coroutine foo ::apply [list {{start 0} {stop 10}} $body]
set res {}
} -body {
for {set k 1} {$k < 4} {incr k} {
lappend res [eval foo $k]
}
set res
} -cleanup {
rename foo {}
unset body res
} -result {0 10 20}
test unsupported-C.1.8 {yield in nested uplevel} -setup {
set body {
# init
set i $start
set imax $stop
yield
while {$i < $imax} {
uplevel 0 yield [expr {$i*$stop}]
incr i
}
}
coroutine foo ::apply [list {{start 0} {stop 10}} $body]
set res {}
} -body {
for {set k 1} {$k < 4} {incr k} {
lappend res [eval foo $k]
}
set res
} -cleanup {
rename foo {}
unset body res
} -result {0 10 20}
test unsupported-C.1.9 {yield in nested eval} -setup {
proc moo {} {
upvar 1 i i stop stop
yield [expr {$i*$stop}]
}
set body {
# init
set i $start
set imax $stop
yield
while {$i < $imax} {
eval moo
incr i
}
}
coroutine foo ::apply [list {{start 0} {stop 10}} $body]
set res {}
} -body {
for {set k 1} {$k < 4} {incr k} {
lappend res [foo $k]
}
set res
} -cleanup {
rename moo {}
unset body res
} -result {0 10 20}
test unsupported-C.1.10 {yield in nested eval} -setup {
set body {
# init
set i $start
set imax $stop
yield
while {$i < $imax} {
eval yield [expr {$i*$stop}]
incr i
}
}
coroutine foo ::apply [list {{start 0} {stop 10}} $body]
set res {}
} -body {
for {set k 1} {$k < 4} {incr k} {
lappend res [eval foo $k]
}
set res
} -cleanup {
unset body res
} -result {0 10 20}
test unsupported-C.1.11 {yield outside coroutine} -setup {
proc moo {} {
upvar 1 i i stop stop
yield [expr {$i*$stop}]
}
} -body {
variable i 5 stop 6
moo
} -cleanup {
rename moo {}
unset i stop
} -returnCodes error -result {yield can only be called in a coroutine}
test unsupported-C.1.12 {proc as coroutine} -setup {
set body {
# init
set i $start
set imax $stop
yield
while {$i < $imax} {
uplevel 0 [list yield [expr {$i*$stop}]]
incr i
}
}
proc moo {{start 0} {stop 10}} $body
coroutine foo moo 2 8
} -body {
list [foo] [foo]
} -cleanup {
unset body
rename moo {}
rename foo {}
} -result {16 24}
test unsupported-C.2.1 {self deletion on return} -body {
coroutine foo set x 3
foo
} -returnCodes error -result {invalid command name "foo"}
test unsupported-C.2.2 {self deletion on return} -body {
coroutine foo ::apply [list {} {yield; yield 1; return 2}]
list [foo] [foo] [catch foo msg] $msg
} -result {1 2 1 {invalid command name "foo"}}
test unsupported-C.2.3 {self deletion on error return} -body {
coroutine foo ::apply [list {} {yield;yield 1; error ouch!}]
list [foo] [catch foo msg] $msg [catch foo msg] $msg
} -result {1 1 ouch! 1 {invalid command name "foo"}}
test unsupported-C.2.4 {self deletion on other return} -body {
coroutine foo ::apply [list {} {yield;yield 1; return -code 100 ouch!}]
list [foo] [catch foo msg] $msg [catch foo msg] $msg
} -result {1 100 ouch! 1 {invalid command name "foo"}}
test unsupported-C.2.5 {deletion of suspended coroutine} -body {
coroutine foo ::apply [list {} {yield; yield 1; return 2}]
list [foo] [rename foo {}] [catch foo msg] $msg
} -result {1 {} 1 {invalid command name "foo"}}
test unsupported-C.2.6 {deletion of running coroutine} -body {
coroutine foo ::apply [list {} {yield; rename foo {}; yield 1; return 2}]
list [foo] [catch foo msg] $msg
} -result {1 1 {invalid command name "foo"}}
test unsupported-C.3.1 {info level computation} -setup {
proc a {} {while 1 {yield [info level]}}
proc b {} foo
} -body {
# note that coroutines execute in uplevel #0
set l0 [coroutine foo a]
set l1 [foo]
set l2 [b]
list $l0 $l1 $l2
} -cleanup {
rename a {}
rename b {}
} -result {1 1 1}
test unsupported-C.3.2 {info frame computation} -setup {
proc a {} {while 1 {yield [info frame]}}
proc b {} foo
} -body {
set l0 [coroutine foo a]
set l1 [foo]
set l2 [b]
expr {$l2 - $l1}
} -cleanup {
rename a {}
rename b {}
} -result 1
test unsupported-C.3.3 {info coroutine} -setup {
proc a {} {info coroutine}
proc b {} a
} -body {
b
} -cleanup {
rename a {}
rename b {}
} -result {}
test unsupported-C.3.4 {info coroutine} -setup {
proc a {} {info coroutine}
proc b {} a
} -body {
coroutine foo b
} -cleanup {
rename a {}
rename b {}
} -result ::foo
test unsupported-C.3.5 {info coroutine} -setup {
proc a {} {info coroutine}
proc b {} {rename [info coroutine] {}; a}
} -body {
coroutine foo b
} -cleanup {
rename a {}
rename b {}
} -result {}
test unsupported-C.4.1 {bug #2093188} -setup {
proc foo {} {
set v 1
trace add variable v {write unset} bar
yield
set v 2
yield
set v 3
}
proc bar args {lappend ::res $args}
coroutine a foo
} -body {
list [a] [a] $::res
} -cleanup {
rename foo {}
rename bar {}
unset ::res
} -result {{} 3 {{v {} write} {v {} write} {v {} unset}}}
test unsupported-C.4.2 {bug #2093188} -setup {
proc foo {} {
set v 1
trace add variable v {read unset} bar
yield
set v 2
set v
yield
set v 3
}
proc bar args {lappend ::res $args}
coroutine a foo
} -body {
list [a] [a] $::res
} -cleanup {
rename foo {}
rename bar {}
unset ::res
} -result {{} 3 {{v {} read} {v {} unset}}}
test unsupported-C.4.2 {bug #2093947} -setup {
proc foo {} {
set v 1
trace add variable v {write unset} bar
yield
set v 2
yield
set v 3
}
proc bar args {lappend ::res $args}
} -body {
coroutine a foo
a
a
coroutine a foo
a
rename a {}
set ::res
} -cleanup {
rename foo {}
rename bar {}
unset ::res
} -result {{v {} write} {v {} write} {v {} unset} {v {} write} {v {} unset}}
test unsupported-C.5.1 {right numLevels on coro return} -constraints {testnrelevels} \
-setup {
proc nestedYield {{val {}}} {
yield $val
}
proc getNumLevel {} {
# remove the level for this proc's call
expr {[lindex [testnrelevels] 1] - 1}
}
proc relativeLevel base {
# remove the level for this proc's call
expr {[getNumLevel] - $base - 1}
}
proc foo {} {
while 1 {
nestedYield
}
}
set res {}
} -body {
set base [getNumLevel]
lappend res [relativeLevel $base]
eval {coroutine a foo}
# back to base level
lappend res [relativeLevel $base]
a
lappend res [relativeLevel $base]
eval a
lappend res [relativeLevel $base]
eval {eval a}
lappend res [relativeLevel $base]
rename a {}
lappend res [relativeLevel $base]
set res
} -cleanup {
rename foo {}
rename nestedYield {}
rename getNumLevel {}
rename relativeLevel {}
unset res
} -result {0 0 0 0 0 0}
test unsupported-C.5.2 {right numLevels within coro} -constraints {testnrelevels} \
-setup {
proc nestedYield {{val {}}} {
yield $val
}
proc getNumLevel {} {
# remove the level for this proc's call
expr {[lindex [testnrelevels] 1] - 1}
}
proc relativeLevel base {
# remove the level for this proc's call
expr {[getNumLevel] - $base - 1}
}
proc foo base {
while 1 {
set base [nestedYield [relativeLevel $base]]
}
}
set res {}
} -body {
lappend res [eval {coroutine a foo [getNumLevel]}]
lappend res [a [getNumLevel]]
lappend res [eval {a [getNumLevel]}]
lappend res [eval {eval {a [getNumLevel]}}]
set base [lindex $res 0]
foreach x $res[set res {}] {
lappend res [expr {$x-$base}]
}
set res
} -cleanup {
rename a {}
rename foo {}
rename nestedYield {}
rename getNumLevel {}
rename relativeLevel {}
unset res
} -result {0 0 0 0}
# cleanup
::tcltest::cleanupTests
unset -nocomplain lambda
if {[testConstraint atProcExit]} {
namespace forget tcl::unsupported::atProcExit
}
if {[testConstraint testnrelevels]} {
namespace forget testnre::*
namespace delete testnre
}
return