path: root/tests/NRE.test

# Commands covered:  proc, apply, [interp alias], [namespce import], tailcall
#
# This file contains a collection of tests for the non-recursive executor that
# avoids recursive calls to TEBC.
#
# 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: NRE.test,v 1.6 2008/07/29 23:18:07 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

testConstraint tailcall [llength [info commands ::tcl::unsupported::tailcall]]
testConstraint teststacklimit [llength [info commands teststacklimit]]

if {[testConstraint teststacklimit]} {
    #
    # Workaround for gnu-make bug http://savannah.gnu.org/bugs/?18396
    #
    # Do not let make set up too large a C stack for us, as it effectively
    # disables the tests under some circumstances
    #

    set oldLimit [teststacklimit 2048]
}

namespace eval testnre {
    #
    # [testnrelevels] returns a 5-list with: C-stack depth, iPtr->numlevels,
    # cmdFrame level, callFrame level and tosPtr 
    #
    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::*


#
# The first few tests will blow the C stack if the NR machinery is not working
# properly: all these calls should execute within the same instance of TEBC,
# and thus do not load the C stack. The nesting limit is given by how much the
# Tcl execution stack can grow. 
#

set oldRecursionLimit [interp recursionlimit {}]
interp recursionlimit {} 100000

test NRE-1.1 {self-recursive procs} -setup {
    variable a {}
    proc a i {
	if {[incr i] > 20000} {
	    return $i
	}
	a $i
    }
} -body {
    list [catch {a 0} msg] $msg
} -cleanup {
    rename a {}
} -result {0 20001}

test NRE-1.1a {self-recursive procs} -setup {
    variable a {}
    proc a i {
	set x [depthDiff]
	if {[incr i] > 10} {
	    return [lrange $x 0 3]
	}
	a $i
    }
} -body {
    a 0
} -cleanup {
    rename a {}
} -result {0 1 1 1}

test NRE-1.2 {self-recursive lambdas} -setup {
    set a [list i {
	if {[incr i] > 20000} {
	    return $i
	}
	apply $::a $i
    }]
} -body {
    list [catch {apply $a 0} msg] $msg
} -cleanup {
    unset a
} -result {0 20001}

test NRE-1.2.1 {self-recursive lambdas} -setup {
    set a [list {} {
	if {[incr ::i] > 20000} {
	    return $::i
	}
	apply $::a
    }]
} -body {
    set ::i 0
    list [catch {apply $a} msg] $msg $::i
} -cleanup {
    unset a
} -result {0 20001 20001}

test NRE-1.3 {mutually recursive procs and lambdas} -setup {
    proc a i {
	apply $::b [incr i]
    }
    set b [list i {
	if {[incr i] > 20000} {
	    return $i
	}
	a $i
    }]
} -body {
    list [catch {list [a 0] [apply $b 0]} msg] $msg
} -cleanup {
    rename a {}
    unset b
} -result {0 {20002 20001}}

#
# Test that aliases are non-recursive
#

test NRE-2.1 {alias is not recursive} -setup {
    proc a i {
	if {[incr i] > 20000} {
	    return $i
	}
	b $i
    }
    interp alias {} b {} a
} -body {
    list [catch {list [a 0] [b 0]} msg] $msg
} -cleanup {
    rename a {}
    rename b {}
} -result {0 {20001 20001}}

#
# Test that imports are non-recursive
#

test NRE-3.1 {imports are not recursive} -setup {
    namespace eval foo {
	proc a i {
	    if {[incr i] > 20000} {
		return $i
	    }
	    ::a $i
	}
	namespace export a
    }
    namespace import foo::a
    a 1
} -body {
    list [catch {a 0} msg] $msg
} -cleanup {
    rename a {}
    namespace delete ::foo
} -result {0 20001}


test NRE-4.1 {ensembles are not recursive} -setup {
    proc a i {
	if {[incr i] > 20000} {
	    return $i
	}
	b foo $i
    }
    namespace ensemble create \
	-command b \
	-map [list foo a]
} -body {
    list [catch {list [a 0] [b foo 0]} msg] $msg
} -cleanup {
    rename a {}
    rename b {}
} -result {0 {20001 20001}}


test NRE-5.1 {[namespace eval] is not recursive} -setup {
    namespace eval ::foo {
	proc a i {
	    if {[incr i] > 20000} {
		return $i
	    }
	    namespace eval ::foo [list a $i]
	}
    }
} -body {
    list [catch {::foo::a 0} msg] $msg
} -cleanup {
    namespace delete ::foo
} -result {0 20001}

test NRE-5.2 {[namespace eval] is not recursive} -setup {
    namespace eval ::foo {
	proc a i {
	    if {[incr i] > 20000} {
		return $i
	    }
	    namespace eval ::foo "set x $i; a $i"
	}
    }
} -body {
    list [catch {::foo::a 0} msg] $msg
} -cleanup {
    namespace delete ::foo
} -result {0 20001}


test NRE-6.1 {[uplevel] is not recursive} -setup {
    proc a i {
	if {[incr i] > 20000} {
	    return $i
	}
	uplevel 1 [list a $i]
    }
} -body {
    list [catch {a 0} msg] $msg
} -cleanup {
    rename a {}
} -result {0 20001}

test NRE-6.2 {[uplevel] is not recursive} -setup {
    proc a i {
	if {[incr i] > 20000} {
	    return $i
	}
	uplevel 1 "set x $i; a $i"
    }
} -body {
    list [catch {a 0} msg] $msg
} -cleanup {
    rename a {}
} -result {0 20001}

#
#  Basic TclOO tests
#

test NRE-oo.1 {really deep calls in oo - direct} -setup {
    oo::object create foo
    oo::objdefine foo method bar i {
	if {[incr i] > 20000} {
	    return $i
	}
	foo bar $i
    }
} -body {
    foo bar 0
} -cleanup {
    foo destroy
} -result 20001

test NRE-oo.2 {really deep calls in oo - call via [self]} -setup {
    oo::object create foo
    oo::objdefine foo method bar i {
	if {[incr i] > 20000} {
	    return $i
	}
	[self] bar $i
    }
} -body {
    foo bar 0
} -cleanup {
    foo destroy
} -result 20001

test NRE-oo.3 {really deep calls in oo - private calls} -setup {
    oo::object create foo
    oo::objdefine foo method bar i {
	if {[incr i] > 20000} {
	    return $i
	}
	my bar $i
    }
} -body {
    foo bar 0
} -cleanup {
    foo destroy
} -result 20001

test NRE-oo.4 {really deep calls in oo - overriding} -setup {
    oo::class create foo {
	method bar i {
	    if {[incr i] > 20000} {
		return $i
	    }
	    my bar $i
	}
    }
    oo::class create boo {
	superclass foo
	method bar i {
	    if {[incr i] > 20000} {
		return $i
	    }
	    next $i
	}
    }
} -body {
    [boo new] bar 0
} -cleanup {
    foo destroy
} -result 20001

test NRE-oo.5 {really deep calls in oo - forwards} -setup {
    oo::object create foo
    oo::objdefine foo {
	method bar i {
	    if {[incr i] > 20000} {
		return $i
	    }
	    my boo $i
	}
	forward boo ::foo bar
    }
} -body {
    foo bar 0
} -cleanup {
    foo destroy
} -result 20001


#
# NASTY BUG found by tcllib's interp package
#

test NRE-X.1 {eval in wrong interp} {
    set i [interp create]
    set res [$i eval {
	set x {namespace children ::}
	set y [list namespace children ::]
	namespace delete {*}[{*}$y]
	set j [interp create]
	$j eval {namespace delete {*}[namespace children ::]}
	namespace eval foo {}
	set res [list [eval $x] [eval $y] [$j eval $x] [$j eval $y]]
	interp delete $j
	set res
    }]
    interp delete $i
    set res
} {::foo ::foo {} {}}

#
# Test tailcalls
#
namespace eval tcl::unsupported namespace export tailcall
namespace import tcl::unsupported::tailcall

test NRE-T.0 {tailcall is constant space} -constraints {tailcall knownbug} -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}

test NRE-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 NRE-T.2 {tailcall in non-proc} -constraints {tailcall} -body {
    list [catch {namespace eval a [list tailcall set x 1]} msg] $msg
} -result {1 {tailcall can only be called from a proc or lambda}}

test NRE-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 NRE-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 NRE-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 NRE-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 NRE-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
	}
	proc d {} {
	    variable res
	    append res d
	    c
	    append res d
	}
    }
} -body {
    namespace eval ::foo d
} -cleanup {
    namespace delete ::foo
} -result dcbabcd

test NRE-T.8 {tailcall tailcall} -constraints {tailcall knownbug} -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
	}
	proc d {} {
	    variable res
	    append res d
	    c
	    append res d
	}
    }
} -body {
    namespace eval ::foo d
} -cleanup {
    namespace delete ::foo
} -result dcbacd

test NRE-T.9 {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
	}
	proc d {} {
	    variable res
	    append res d
	    c
	    append res d
	}
    }
} -body {
    namespace eval ::foo d
} -cleanup {
    namespace delete ::foo
} -result dcbabcd

test NRE-T.10 {tailcall tailcall} -constraints {tailcall knownbug} -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
	}
	proc d {} {
	    variable res
	    append res d
	    c
	    append res d
	}
    }
} -body {
    namespace eval ::foo d
} -cleanup {
    namespace delete ::foo
} -result dcbacd

test NRE-T.11 {tailcall tailcall} -constraints {tailcall knownbug} -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
	}
	proc d {} {
	    variable res
	    append res d
	    c
	    append res d
	}
    }
} -body {
    namespace eval ::foo d
} -cleanup {
    namespace delete ::foo
} -result dcbacd


namespace forget tcl::unsupported::tailcall
#
# Test that ensembles are non-recursive
#



# cleanup
::tcltest::cleanupTests

interp recursionlimit {} $oldRecursionLimit
unset oldRecursionLimit

if {[testConstraint teststacklimit]} {
    teststacklimit $oldLimit
    unset oldLimit
}
namespace delete testnre

return