path: root/tests/unsupported.test

# 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.10 2008/09/05 01:20:01 msofer 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]]
testConstraint tailcall [llength [info commands ::tcl::unsupported::tailcall]]
testConstraint coroutine [llength [info commands ::tcl::unsupported::yield]]

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 {tailcall} -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} -constraints {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} -constraints {tailcall} -body {
    namespace eval a [list tailcall set x 1]
} -match glob -result *tailcall* -returnCodes error

test unsupported-T.3 {tailcall falls off tebc} -constraints {tailcall} -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} -constraints {tailcall} -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} -constraints {tailcall} -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} -constraints {tailcall} -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} -constraints {tailcall} -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} -constraints {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} -constraints {tailcall} -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 tailcall
} -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
#

if {[testConstraint coroutine]} {
    namespace import tcl::unsupported::coroutine
    namespace import tcl::unsupported::yield
}

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} -constraints {coroutine} \
-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} -constraints {coroutine} \
-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} -constraints {coroutine} \
-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} -constraints {coroutine} \
-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} -constraints {coroutine} \
-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} -constraints {coroutine} \
-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} -constraints {coroutine} \
-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} -constraints {coroutine} \
-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} -constraints {coroutine} \
-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} -constraints {coroutine} \
-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} -constraints {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} -constraints {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} -constraints {coroutine} \
-body {
    coroutine foo set x 3
    foo
} -returnCodes error -result {invalid command name "foo"}

test unsupported-C.2.2 {self deletion on return} -constraints {coroutine} \
-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} -constraints {coroutine} \
-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} -constraints {coroutine} \
-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} -constraints {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} -constraints {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} -constraints {coroutine} \
-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} -constraints {coroutine} \
-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} -constraints {coroutine} \
-setup {
    proc a {} {infoCoroutine}
    proc b {} a
} -body {
    b
} -cleanup {
    rename a {}
    rename b {}
} -result {}

test unsupported-C.3.4 {info coroutine} -constraints {coroutine} \
-setup {
    proc a {} {infoCoroutine}
    proc b {} a
} -body {
    coroutine foo b
} -cleanup {
    rename a {}
    rename b {}
} -result ::foo


test unsupported-C.4.1 {bug #2093188} -constraints {coroutine} \
-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} -constraints {coroutine} \
-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} -constraints {coroutine} \
-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}}

# cleanup
::tcltest::cleanupTests


unset -nocomplain lambda

if {[testConstraint tailcall]} {
    namespace forget tcl::unsupported::tailcall
}

if {[testConstraint atProcExit]} {
    namespace forget tcl::unsupported::atProcExit
}

if {[testConstraint coroutine]} {
    namespace forget tcl::unsupported::coroutine
    namespace forget tcl::unsupported::yield
}

if {[testConstraint testnrelevels]} {
    namespace forget testnre::*
    namespace delete testnre
}

return