summaryrefslogtreecommitdiffstats
path: root/tests/tailcall.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/tailcall.test')
-rw-r--r--tests/tailcall.test663
1 files changed, 663 insertions, 0 deletions
diff --git a/tests/tailcall.test b/tests/tailcall.test
new file mode 100644
index 0000000..e9ec188
--- /dev/null
+++ b/tests/tailcall.test
@@ -0,0 +1,663 @@
+# 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 {[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:
generated by cgit v0.12 at 2024-11-09 06:00:34 (GMT)