717 lines
16 KiB
Plaintext
717 lines
16 KiB
Plaintext
# 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.
|
||
|
||
if {"::tcltest" ni [namespace children]} {
|
||
package require tcltest 2.5
|
||
namespace import -force ::tcltest::*
|
||
}
|
||
|
||
::tcltest::loadTestedCommands
|
||
catch [list package require -exact Tcltest [info patchlevel]]
|
||
|
||
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.5.1 {tailcall is constant space} -constraints testnrelevels -setup {
|
||
#
|
||
# This test is related to [bug d87cb182053fd79b3]: the fix to that bug was
|
||
# to remove a call to TclSkipTailcall, which caused a violation of the
|
||
# constant-space property of tailcall in that particular
|
||
# configuration. This test was added to detect that, and insure that the
|
||
# problem is fixed.
|
||
#
|
||
|
||
proc b i {
|
||
if {$i == 1} {
|
||
depthDiff
|
||
}
|
||
if {[incr i] > 10} {
|
||
return [depthDiff]
|
||
}
|
||
tailcall dict b $i
|
||
}
|
||
set map0 [namespace ensemble configure dict -map]
|
||
set map $map0
|
||
dict set map b b
|
||
namespace ensemble configure dict -map $map
|
||
} -body {
|
||
dict b 0
|
||
} -cleanup {
|
||
rename b {}
|
||
namespace ensemble configure dict -map $map0
|
||
unset map map0
|
||
} -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
|
||
}
|
||
|
||
test tailcall-14.1 {in a deleted namespace} -body {
|
||
namespace eval ns {
|
||
proc p args {
|
||
tailcall [namespace current] $args
|
||
}
|
||
namespace delete [namespace current]
|
||
p
|
||
}
|
||
} -returnCodes 1 -result {namespace "::ns" not found}
|
||
|
||
test tailcall-14.1-bc {{in a deleted namespace} {byte compiled}} -body {
|
||
namespace eval ns {
|
||
proc p args {
|
||
tailcall [namespace current] {*}$args
|
||
}
|
||
namespace delete [namespace current]
|
||
p
|
||
}
|
||
} -returnCodes 1 -result {namespace "::ns" not found}
|
||
|
||
# cleanup
|
||
::tcltest::cleanupTests
|
||
|
||
# Local Variables:
|
||
# mode: tcl
|
||
# End:
|