diff options
Diffstat (limited to 'tests/tailcall.test')
| -rw-r--r-- | tests/tailcall.test | 665 |
1 files changed, 0 insertions, 665 deletions
diff --git a/tests/tailcall.test b/tests/tailcall.test deleted file mode 100644 index 46e2471..0000000 --- a/tests/tailcall.test +++ /dev/null @@ -1,665 +0,0 @@ -# Commands covered: tailcall -# -# 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: tailcall.test,v 1.14 2010/08/30 14:02:10 msofer Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} - -testConstraint testnrelevels [llength [info commands testnrelevels]] - -# -# 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 - } - namespace export * - } - namespace import testnre::* -} - -proc errorcode options { - dict get [dict merge {-errorcode NONE} $options] -errorcode -} - -test tailcall-0.1 {tailcall is constant space} -constraints testnrelevels -setup { - proc a i { - # - # NOTE: there may be a diff in callback depth with the first call - # ($i==0) due to the fact that the first is from an eval. Successive - # calls should add nothing to any stack depths. - # - if {$i == 1} { - depthDiff - } - if {[incr i] > 10} { - return [depthDiff] - } - tailcall a $i - } -} -body { - a 0 -} -cleanup { - rename a {} -} -result {0 0 0 0 0 0} - -test tailcall-0.2 {tailcall is constant space} -constraints testnrelevels -setup { - set a { i { - if {$i == 1} { - depthDiff - } - if {[incr i] > 10} { - return [depthDiff] - } - upvar 1 a a - tailcall apply $a $i - }} -} -body { - apply $a 0 -} -cleanup { - unset a -} -result {0 0 0 0 0 0} - -test tailcall-0.3 {tailcall is constant space} -constraints testnrelevels -setup { - proc a i { - if {$i == 1} { - depthDiff - } - if {[incr i] > 10} { - return [depthDiff] - } - tailcall b $i - } - interp alias {} b {} a -} -body { - b 0 -} -cleanup { - rename a {} - rename b {} -} -result {0 0 0 0 0 0} - -test tailcall-0.4 {tailcall is constant space} -constraints testnrelevels -setup { - namespace eval ::ns { - namespace export * - } - proc ::ns::a i { - if {$i == 1} { - depthDiff - } - if {[incr i] > 10} { - return [depthDiff] - } - set b [uplevel 1 [list namespace which b]] - tailcall $b $i - } - namespace import ::ns::a - rename a b -} -body { - b 0 -} -cleanup { - rename b {} - namespace delete ::ns -} -result {0 0 0 0 0 0} - -test tailcall-0.5 {tailcall is constant space} -constraints testnrelevels -setup { - proc b i { - if {$i == 1} { - depthDiff - } - if {[incr i] > 10} { - return [depthDiff] - } - tailcall a b $i - } - namespace ensemble create -command a -map {b b} -} -body { - a b 0 -} -cleanup { - rename a {} - rename b {} -} -result {0 0 0 0 0 0} - -test tailcall-0.6 {tailcall is constant space} -constraints {testnrelevels knownBug} -setup { - # - # This test fails because ns-unknown is not NR-enabled - # - proc c i { - if {$i == 1} { - depthDiff - } - if {[incr i] > 10} { - return [depthDiff] - } - tailcall a b $i - } - proc d {ens sub args} { - return [list $ens c] - } - namespace ensemble create -command a -unknown d -} -body { - a b 0 -} -cleanup { - rename a {} - rename c {} - rename d {} -} -result {0 0 0 0 0 0} - -test tailcall-0.7 {tailcall is constant space} -constraints testnrelevels -setup { - catch {rename foo {}} - oo::class create foo { - method b i { - if {$i == 1} { - depthDiff - } - if {[incr i] > 10} { - return [depthDiff] - } - tailcall [self] b $i - } - } -} -body { - foo create a - a b 0 -} -cleanup { - rename a {} - rename foo {} -} -result {0 0 0 0 0 0} - -test tailcall-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 tailcall-2 {tailcall in non-proc} -body { - namespace eval a [list tailcall set x 1] -} -match glob -result *tailcall* -returnCodes error - -test tailcall-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 tailcall-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 tailcall-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 tailcall-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 tailcall-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 tailcall-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 -} -result cbac - -test tailcall-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 tailcall-10a {tailcall and eval} -setup { - set ::x 0 - proc a {} { - eval [list tailcall lappend ::x 2] - set ::x 1 - } -} -body { - list [a] $::x -} -cleanup { - unset -nocomplain ::x -} -result {{0 2} {0 2}} - -test tailcall-10b {tailcall and eval} -setup { - set ::x 0 - proc a {} { - eval {tailcall lappend ::x 2} - set ::x 1 - } -} -body { - list [a] $::x -} -cleanup { - unset -nocomplain ::x -} -result {{0 2} {0 2}} - -test tailcall-11a {tailcall and uplevel} -setup { - proc a {} { - uplevel 1 [list tailcall set ::x 2] - set ::x 1 - } -} -body { - list [a] $::x -} -cleanup { - unset -nocomplain ::x -} -match glob -result *tailcall* -returnCodes error - -test tailcall-11b {tailcall and uplevel} -setup { - proc a {} { - uplevel 1 {tailcall set ::x 2} - set ::x 1 - } -} -body { - list [a] $::x -} -cleanup { - unset -nocomplain ::x -} -match glob -result *tailcall* -returnCodes error - -test tailcall-11c {tailcall and uplevel} -setup { - proc a {} { - uplevel 1 {tailcall lappend ::x 2} - set ::x 1 - } - proc b {} {set ::x 0; a; lappend ::x 3} -} -body { - list [b] $::x -} -cleanup { - rename a {} - rename b {} - unset -nocomplain ::x -} -result {{0 3 2} {0 3 2}} - -test tailcall-12.1 {[Bug 2649975]} -setup { - proc dump {{text {}}} { - set text [uplevel 1 [list subst $text]] - set l [expr {[info level] -1}] - if {$text eq {}} { - set text [info level $l] - } - puts "$l: $text" - } - # proc dump args {} - proc bravo {} { - upvar 1 v w - dump {inside bravo, v -> $w} - set v "procedure bravo" - #uplevel 1 [list delta ::betty] - uplevel 1 {delta ::betty} - return $::resolution - } - proc delta name { - upvar 1 v w - dump {inside delta, v -> $w} - set v "procedure delta" - tailcall foxtrot - } - proc foxtrot {} { - upvar 1 v w - dump {inside foxtrot, v -> $w} - global resolution - set ::resolution $w - } - set v "global level" -} -body { - set result [bravo] - if {$result ne $v} { - puts "v should have been found at $v but was found in $result" - } -} -cleanup { - unset v - rename dump {} - rename bravo {} - rename delta {} - rename foxtrot {} -} -output {1: inside bravo, v -> global level -1: inside delta, v -> global level -1: inside foxtrot, v -> global level -} - -test tailcall-12.2 {[Bug 2649975]} -setup { - proc dump {{text {}}} { - set text [uplevel 1 [list subst $text]] - set l [expr {[info level] -1}] - if {$text eq {}} { - set text [info level $l] - } - puts "$l: $text" - } - # proc dump args {} - set v "global level" - oo::class create foo { # like connection - method alpha {} { # like connections 'tables' method - dump - upvar 1 v w - dump {inside foo's alpha, v resolves to $w} - set v "foo's method alpha" - dump {foo's alpha is calling [self] bravo - v should resolve at global level} - set result [uplevel 1 [list [self] bravo]] - dump {exiting from foo's alpha} - return $result - } - method bravo {} { # like connections 'foreach' method - dump - upvar 1 v w - dump {inside foo's bravo, v resolves to $w} - set v "foo's method bravo" - dump {foo's bravo is calling charlie to create barney} - set barney [my charlie ::barney] - dump {foo's bravo is calling bravo on $barney} - dump {v should resolve at global scope there} - set result [uplevel 1 [list $barney bravo]] - dump {exiting from foo's bravo} - return $result - } - method charlie {name} { # like tdbc prepare - dump - set v "foo's method charlie" - dump {tailcalling bar's constructor} - tailcall ::bar create $name - } - } - oo::class create bar { # like statement - method bravo {} { # like statement foreach method - dump - upvar 1 v w - dump {inside bar's bravo, v is resolving to $w} - set v "bar's method bravo" - dump {calling delta to construct betty - v should resolve global there} - uplevel 1 [list [self] delta ::betty] - dump {exiting from bar's bravo} - return [::betty whathappened] - } - method delta {name} { # like statement execute method - dump - upvar 1 v w - dump {inside bar's delta, v is resolving to $w} - set v "bar's method delta" - dump {tailcalling to construct $name as instance of grill} - dump {v should resolve at global level in grill's constructor} - dump {grill's constructor should run at level [info level]} - tailcall grill create $name - } - } - oo::class create grill { - variable resolution - constructor {} { - dump - upvar 1 v w - dump "in grill's constructor, v resolves to $w" - set resolution $w - } - method whathappened {} { - return $resolution - } - } - foo create fred -} -body { - set result [fred alpha] - if {$result ne "global level"} { - puts "v should have been found at global level but was found in $result" - } -} -cleanup { - unset result - rename fred {} - rename dump {} - rename foo {} - rename bar {} - rename grill {} -} -output {1: fred alpha -1: inside foo's alpha, v resolves to global level -1: foo's alpha is calling ::fred bravo - v should resolve at global level -1: ::fred bravo -1: inside foo's bravo, v resolves to global level -1: foo's bravo is calling charlie to create barney -2: my charlie ::barney -2: tailcalling bar's constructor -1: foo's bravo is calling bravo on ::barney -1: v should resolve at global scope there -1: ::barney bravo -1: inside bar's bravo, v is resolving to global level -1: calling delta to construct betty - v should resolve global there -1: ::barney delta ::betty -1: inside bar's delta, v is resolving to global level -1: tailcalling to construct ::betty as instance of grill -1: v should resolve at global level in grill's constructor -1: grill's constructor should run at level 1 -1: grill create ::betty -1: in grill's constructor, v resolves to global level -1: exiting from bar's bravo -1: exiting from foo's bravo -1: exiting from foo's alpha -} - -test tailcall-12.3a0 {[Bug 2695587]} -body { - apply {{} { - catch [list tailcall foo] - }} -} -returnCodes 1 -result {invalid command name "foo"} - -test tailcall-12.3a1 {[Bug 2695587]} -body { - apply {{} { - catch [list tailcall foo] - tailcall - }} -} -result {} - -test tailcall-12.3a2 {[Bug 2695587]} -body { - apply {{} { - catch [list tailcall foo] - tailcall moo - }} -} -returnCodes 1 -result {invalid command name "moo"} - -test tailcall-12.3a3 {[Bug 2695587]} -body { - set x 0 - apply {{} { - catch [list tailcall foo] - tailcall lappend x 1 - }} - set x -} -cleanup { - unset x -} -result {0 1} - -test tailcall-12.3b0 {[Bug 2695587]} -body { - apply {{} { - set catch catch - $catch [list tailcall foo] - }} -} -returnCodes 1 -result {invalid command name "foo"} - -test tailcall-12.3b1 {[Bug 2695587]} -body { - apply {{} { - set catch catch - $catch [list tailcall foo] - tailcall - }} -} -result {} - -test tailcall-12.3b2 {[Bug 2695587]} -body { - apply {{} { - set catch catch - $catch [list tailcall foo] - tailcall moo - }} -} -returnCodes 1 -result {invalid command name "moo"} - -test tailcall-12.3b3 {[Bug 2695587]} -body { - set x 0 - apply {{} { - set catch catch - $catch [list tailcall foo] - tailcall lappend x 1 - }} - set x -} -cleanup { - unset x -} -result {0 1} - -# MORE VARIANTS MISSING: bc'ed caught script vs (bc'ed, not-bc'ed) -# catch. Actually superfluous now, as tailcall just returns TCL_RETURN so that -# standard catch behaviour is required. - -test tailcall-13.1 {directly tailcalling the tailcall command is ok} { - list [catch { - apply {{} { - apply {{} { - tailcall tailcall subst ok - subst b - }} - subst c - }} - } msg opt] $msg [errorcode $opt] -} {0 ok NONE} -test tailcall-13.2 {indirectly tailcalling the tailcall command is ok} { - list [catch { - apply {{} { - apply {{} { - tailcall eval tailcall subst ok - subst b - }} - subst c - }} - } msg opt] $msg [errorcode $opt] -} {0 ok NONE} - -if {[testConstraint testnrelevels]} { - namespace forget testnre::* - namespace delete testnre -} - -# cleanup -::tcltest::cleanupTests - -# Local Variables: -# mode: tcl -# End: |