path: root/tests/nre.test

# Commands covered:  proc, apply, [interp alias], [namespce import]
#
# This file contains a collection of tests for the non-recursive executor that
# avoids recursive calls to TEBC. Only the NRE behaviour is tested here, the
# actual command functionality is tested in the specific test file.
#
# 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.1 2008/08/02 14:12:56 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
	}
	proc setabs {} {
	    uplevel 1 variable abs -[lindex [testnrelevels] 0]
	}

	variable body0 {
	    set x [depthDiff]
	    if {[incr i] > 10} {
		variable abs
		incr abs [lindex [testnrelevels] 0]
		return [list [lrange $x 0 3] $abs]
	    }
	}
	proc makebody txt {
	    variable body0
	    return "$body0; $txt"
	}
	namespace export *
    }
    namespace import testnre::*
}

test nre-1.1 {self-recursive procs} -setup {
    proc a i [makebody {a $i}]
} -body {
    setabs
    a 0
} -cleanup {
    rename a {}
    unset abs
} -result {{0 1 1 1} 0}

test nre-1.2 {self-recursive lambdas} -setup {
    set a [list i [makebody {apply $::a $i}]]
} -body {
    setabs
    apply $a 0
} -cleanup {
    unset a abs
} -result {{0 1 1 1} 0}

test nre-1.3 {mutually recursive procs and lambdas} -setup {
    proc a i {
	apply $::b [incr i]
    }
    set b [list i [makebody {a $i}]]
} -body {
    setabs
    a 0
} -cleanup {
    rename a {}
    unset b abs
} -result {{0 2 2 2} 0}

#
# Test that aliases are non-recursive
#

test nre-2.1 {alias is not recursive} -setup {
    proc a i [makebody {b $i}]
    interp alias {} b {} a
} -body {
    setabs
    a 0
} -cleanup {
    rename a {}
    rename b {}
    unset abs
} -result {{0 2 1 1} 0}

#
# Test that imports are non-recursive
#

test nre-3.1 {imports are not recursive} -setup {
    namespace eval foo {
	setabs
	namespace export a
    }
    proc foo::a i [makebody {::a $i}]
    namespace import foo::a
} -body {
    a 0
} -cleanup {
    rename a {}
    namespace delete ::foo
} -result {{0 2 1 1} 0}

test nre-4.1 {ensembles are not recursive} -setup {
    proc a i [makebody {b foo $i}]
    namespace ensemble create \
	-command b \
	-map [list foo a]
} -body {
    setabs
    a 0
} -cleanup {
    rename a {}
    rename b {}
    unset abs
} -result {{0 2 1 1} 0}

test nre-5.1 {[namespace eval] is not recursive} -setup {
    namespace eval ::foo {
	setabs
    }
    proc foo::a i [makebody {namespace eval ::foo [list a $i]}]
} -body {
    ::foo::a 0
} -cleanup {
    namespace delete ::foo
} -result {{0 2 2 2} 0}

test nre-5.2 {[namespace eval] is not recursive} -setup {
    namespace eval ::foo {
	setabs
    }
    proc foo::a i [makebody {namespace eval ::foo "set x $i; a $i"}]
} -body {
    foo::a 0
} -cleanup {
    namespace delete ::foo
} -result {{0 2 2 2} 0}

test nre-6.1 {[uplevel] is not recursive} -setup {
    proc a i [makebody {uplevel 1 [list a $i]}]
} -body {
    setabs
    a 0
} -cleanup {
    rename a {}
    unset abs
} -result {{0 2 2 0} 0}

test nre-6.2 {[uplevel] is not recursive} -setup {
    setabs
    proc a i [makebody {uplevel 1 "set x $i; a $i"}]
} -body {
    a 0
} -cleanup {
    rename a {}
    unset abs
} -result {{0 2 2 0} 0}

test nre-7.1 {[catch] is not recursive} -setup {
    setabs
    proc a i [makebody {uplevel 1 "catch {a $i} msg; set msg"}]
} -body {
    a 0
} -cleanup {
    rename a {}
    unset x abs
} -result {{0 3 3 0} 0}

#
#  Basic TclOO tests
#

test nre-oo.1 {really deep calls in oo - direct} -setup {
    oo::object create foo
    oo::objdefine foo method bar i [makebody {foo bar $i}]
} -body {
    setabs
    foo bar 0
} -cleanup {
    foo destroy
    unset abs
} -result {{0 1 1 1} 0}

test nre-oo.2 {really deep calls in oo - call via [self]} -setup {
    oo::object create foo
    oo::objdefine foo method bar i [makebody {[self] bar $i}]
} -body {
    setabs
    foo bar 0
} -cleanup {
    foo destroy
    unset abs
} -result {{0 1 1 1} 0}

test nre-oo.3 {really deep calls in oo - private calls} -setup {
    oo::object create foo
    oo::objdefine foo method bar i [makebody {my bar $i}]
} -body {
    setabs
    foo bar 0
} -cleanup {
    foo destroy
    unset abs
} -result {{0 1 1 1} 0}

test nre-oo.4 {really deep calls in oo - overriding} -setup {
    oo::class create foo {
	method bar i [makebody {my bar $i}]
    }
    oo::class create boo {
	superclass foo
	method bar i [makebody {next $i}]
    }
} -body {
    setabs
    [boo new] bar 0
} -cleanup {
    foo destroy
    unset abs
} -result {{0 1 1 1} 0}

test nre-oo.5 {really deep calls in oo - forwards} -setup {
    oo::object create foo
    set body [makebody {my boo $i}]
    oo::objdefine foo "
	method bar i {$body}
	forward boo ::foo bar
    "
} -body {
    setabs
    foo bar 0
} -cleanup {
    foo destroy
    unset abs
} -result {{0 2 1 1} 0}


#
# 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 {} {}}


# cleanup
::tcltest::cleanupTests

if {[testConstraint testnrelevels]} {
    namespace forget testnre::*
    namespace delete testnre
}

return