path: root/tests/tailcall.test

# 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: