diff options
Diffstat (limited to 'tcl8.6/tests/nre.test')
| -rw-r--r-- | tcl8.6/tests/nre.test | 451 |
1 files changed, 451 insertions, 0 deletions
diff --git a/tcl8.6/tests/nre.test b/tcl8.6/tests/nre.test new file mode 100644 index 0000000..9df5eb1 --- /dev/null +++ b/tcl8.6/tests/nre.test @@ -0,0 +1,451 @@ +# 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. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + 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 { + namespace path ::tcl::mathop + # + # [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 {} { + variable abs [- [lindex [testnrelevels] 0]] + } + + variable body0 { + set x [depthDiff] + if {[incr i] > 10} { + namespace upvar [namespace qualifiers \ + [namespace origin depthDiff]] abs 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-0.1 {levels while unwinding} { + testnreunwind +} {0 0 0} + +test nre-1.1 {self-recursive procs} -setup { + proc a i [makebody {a $i}] +} -body { + setabs + a 0 +} -cleanup { + rename a {} +} -constraints { + testnrelevels +} -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 +} -constraints { + testnrelevels +} -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 +} -constraints { + testnrelevels +} -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 {} +} -constraints { + testnrelevels +} -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 +} -constraints { + testnrelevels +} -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 {} +} -constraints { + testnrelevels +} -result {{0 2 1 1} 0} + +test nre-4.2 {(compiled) ensembles do not break tailcall} -setup { + # Fix Bug d87cb18205 + proc b {} { + tailcall append result first + } + set map [namespace ensemble configure ::dict -map] + dict set map a b + namespace ensemble configure ::dict -map $map + proc demo {} { + dict a + append result second + } +} -body { + demo +} -cleanup { + rename demo {} + namespace ensemble configure ::dict -map [dict remove $map a] + unset map + rename b {} +} -result firstsecond + +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 +} -constraints { + testnrelevels +} -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 +} -constraints { + testnrelevels +} -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 {} +} -constraints { + testnrelevels +} -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 {} +} -constraints { + testnrelevels +} -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 {} +} -constraints { + testnrelevels +} -result {{0 3 3 0} 0} +test nre-7.2 {[if] is not recursive} -setup { + setabs + proc a i [makebody {uplevel 1 "if 1 {a $i}"}] +} -body { + a 0 +} -cleanup { + rename a {} +} -constraints { + testnrelevels +} -result {{0 2 2 0} 0} +test nre-7.3 {[while] is not recursive} -setup { + setabs + proc a i [makebody {uplevel 1 "while 1 {set res \[a $i\]; break}; set res"}] +} -body { + a 0 +} -cleanup { + rename a {} +} -constraints { + testnrelevels +} -result {{0 2 2 0} 0} +test nre-7.4 {[for] is not recursive} -setup { + setabs + proc a i [makebody {uplevel 1 "for {set j 0} {\$j < 10} {incr j} {set res \[a $i\]; break}; set res"}] +} -body { + a 0 +} -cleanup { + rename a {} +} -constraints { + testnrelevels +} -result {{0 2 2 0} 0} +test nre-7.5 {[foreach] is not recursive} -setup { + # + # Enable once [foreach] is NR-enabled + # + setabs + proc a i [makebody {uplevel 1 "foreach j {1 2 3 4 5 6} {set res \[a $i\]; break}; set res"}] +} -body { + a 0 +} -cleanup { + rename a {} +} -constraints { + testnrelevels +} -result {{0 3 3 0} 0} +test nre-7.6 {[eval] is not recursive} -setup { + proc a i [makebody {eval [list a $i]}] +} -body { + setabs + a 0 +} -cleanup { + rename a {} +} -constraints { + testnrelevels +} -result {{0 2 2 1} 0} +test nre-7.7 {[eval] is not recursive} -setup { + proc a i [makebody {eval "a $i"}] +} -body { + setabs + a 0 +} -cleanup { + rename a {} +} -constraints { + testnrelevels +} -result {{0 2 2 1} 0} +test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup { + proc foo args {} + foo + coroutine bar apply {{} { + yield + proc foo args {return ok} + while 1 { + yield [incr i] + foo + } + }} +} -body { + # if switching to plain eval is not nre aware, this will cause a "cannot + # yield" error + list [bar] [bar] [bar] +} -cleanup { + rename bar {} + rename foo {} +} -result {1 2 3} + +test nre-8.1 {nre and {*}} -body { + # force an expansion that grows the evaluation stack, check that nre + # adapts the TEBCdataPtr. This crashes on failure. + proc inner {} { + set long [lrepeat 1000000 1] + list {*}$long + } + proc outer {} inner + lrange [outer] 0 2 +} -cleanup { + rename inner {} + rename outer {} +} -result {1 1 1} +test nre-8.2 {nre and {*}, [Bug 2415422]} -body { + # force an expansion that grows the evaluation stack, check that nre + # adapts the bcFramePtr. This causes an NRE assertion to fail if it is not + # done properly. + proc nop {} {} + proc crash {} { + foreach val [list {*}[lrepeat 100000 x]] { + nop + } + } + crash +} -cleanup { + rename nop {} + rename crash {} +} + +# +# 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 +} -constraints { + testnrelevels +} -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 +} -constraints { + testnrelevels +} -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 +} -constraints { + testnrelevels +} -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 +} -constraints { + testnrelevels +} -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 +} -constraints { + testnrelevels +} -result {{0 2 1 1} 0} + +# +# NASTY BUG found by tcllib's interp package +# + +test nre-X.1 {eval in wrong interp} -setup { + set i [interp create] + $i eval {proc filter lst {lsearch -all -inline -not $lst "::tcl"}} +} -body { + $i eval { + set x {namespace children ::} + set y [list namespace children ::] + namespace delete {*}[filter [{*}$y]] + set j [interp create] + $j alias filter filter + $j eval {namespace delete {*}[filter [namespace children ::]]} + namespace eval foo {} + list [filter [eval $x]] [filter [eval $y]] [filter [$j eval $x]] [filter [$j eval $y]] + } +} -cleanup { + interp delete $i +} -result {::foo ::foo {} {}} + +# cleanup +::tcltest::cleanupTests + +if {[testConstraint testnrelevels]} { + namespace forget testnre::* + namespace delete testnre +} + +return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: |