454 lines
9.9 KiB
Plaintext
454 lines
9.9 KiB
Plaintext
|
# 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 {"::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 {
|
|||
|
|
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} -body {
|
|||
|
|
testnreunwind
|
|||
|
|
} -constraints {
|
|||
|
|
testnrelevels
|
|||
|
|
} -result {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:
|