summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2008-08-01 00:44:04 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2008-08-01 00:44:04 (GMT)
commit6defa80ae783c5777b9d9e152d512bb722e3417d (patch)
treea44b66f0846bb3bffc966c9f8b4dca137f401ef2
parent74eb24e991b20268a699c69978e770adab5c8b2f (diff)
downloadtcl-6defa80ae783c5777b9d9e152d512bb722e3417d.zip
tcl-6defa80ae783c5777b9d9e152d512bb722e3417d.tar.gz
tcl-6defa80ae783c5777b9d9e152d512bb722e3417d.tar.bz2
* tests/NRE.test: replaced all deep-recursing tests by shallower
tests that actually measure the C-stack depth. This makes them bearable again (even under memdebug) and avoid crashing on failure.
-rw-r--r--ChangeLog4
-rw-r--r--tests/NRE.test368
2 files changed, 126 insertions, 246 deletions
diff --git a/ChangeLog b/ChangeLog
index a4fc26a..d645141 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,9 @@
2008-07-31 Miguel Sofer <msofer@users.sf.net>
+ * tests/NRE.test: replaced all deep-recursing tests by shallower
+ tests that actually measure the C-stack depth. This makes them
+ bearable again (even under memdebug) and avoid crashing on failure.
+
* generic/tclBasic.c: NR-enabling [catch], [if] and [for] and
* generic/tclCmdAH.c: [while] (the script, not the tests)
* generic/tclCmdIL.c:
diff --git a/tests/NRE.test b/tests/NRE.test
index dfa6f59..4a279bc 100644
--- a/tests/NRE.test
+++ b/tests/NRE.test
@@ -8,7 +8,7 @@
# 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.9 2008/07/31 15:42:08 msofer Exp $
+# RCS: @(#) $Id: NRE.test,v 1.10 2008/08/01 00:44:05 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -16,171 +16,98 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
}
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 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::*
-
+testConstraint testnrelevels [llength [info commands testnrelevels]]
#
-# 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.
+# The tests that risked blowing the C stack on failure have been removed: we
+# can now actually measure using testnrelevels.
#
-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
+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]
}
- 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]
+ 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"
}
- a $i
+ 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 {}
-} -result {0 1 1 1}
+ unset abs
+} -result {{0 1 1 1} 0}
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.2a {self-recursive lambdas} -setup {
- set a [list i {
- set x [depthDiff]
- if {[incr i] > 10} {
- return [lrange $x 0 3]
- }
- apply $::a $i
- }]
+ set a [list i [makebody {apply $::a $i}]]
} -body {
+ setabs
apply $a 0
} -cleanup {
- unset a
-} -result {0 1 1 1}
-
-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}
+ 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 {
- if {[incr i] > 20000} {
- return $i
- }
- a $i
- }]
+ set b [list i [makebody {a $i}]]
} -body {
- list [catch {list [a 0] [apply $b 0]} msg] $msg
+ setabs
+ a 0
} -cleanup {
rename a {}
- unset b
-} -result {0 {20002 20001}}
+ 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 {
- 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 NRE-2.1a {alias is not recursive} -setup {
- proc a i {
- set x [depthDiff]
- if {[incr i] > 10} {
- return [lrange $x 0 3]
- }
- b $i
- }
+ proc a i [makebody {b $i}]
interp alias {} b {} a
} -body {
- list [a 0] [b 0]
+ setabs
+ a 0
} -cleanup {
rename a {}
rename b {}
-} -result {{0 2 1 1} {0 2 1 1}}
+ unset abs
+} -result {{0 2 1 1} 0}
#
# Test that imports are non-recursive
@@ -188,119 +115,83 @@ test NRE-2.1a {alias is not recursive} -setup {
test NRE-3.1 {imports are not recursive} -setup {
namespace eval foo {
- proc a i {
- set x [depthDiff]
- if {[incr i] > 10} {
- return [lrange $x 0 3]
- }
- ::a $i
- }
+ setabs
namespace export a
}
+ proc foo::a i [makebody {::a $i}]
namespace import foo::a
- a 1
} -body {
a 0
} -cleanup {
rename a {}
namespace delete ::foo
-} -result {0 2 1 1}
-
+} -result {{0 2 1 1} 0}
test NRE-4.1 {ensembles are not recursive} -setup {
- proc a i {
- set x [depthDiff]
- if {[incr i] > 10} {
- return [lrange $x 0 3]
- }
- b foo $i
- }
+ proc a i [makebody {b foo $i}]
namespace ensemble create \
-command b \
-map [list foo a]
} -body {
- list [a 0] [b foo 0]
+ setabs
+ a 0
} -cleanup {
rename a {}
rename b {}
-} -result {{0 2 1 1} {0 2 1 1}}
-
+ unset abs
+} -result {{0 2 1 1} 0}
test NRE-5.1 {[namespace eval] is not recursive} -setup {
namespace eval ::foo {
- proc a i {
- set x [depthDiff]
- if {[incr i] > 10} {
- return [lrange $x 0 3]
- }
- namespace eval ::foo [list a $i]
- }
+ 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}
+} -result {{0 2 2 2} 0}
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"
- }
+ setabs
}
+ proc foo::a i [makebody {namespace eval ::foo "set x $i; a $i"}]
} -body {
- list [catch {::foo::a 0} msg] $msg
+ foo::a 0
} -cleanup {
namespace delete ::foo
-} -result {0 20001}
-
+} -result {{0 2 2 2} 0}
test NRE-6.1 {[uplevel] is not recursive} -setup {
- proc a i {
- set x [depthDiff]
- if {[incr i] > 10} {
- return [lrange $x 0 3]
- }
- uplevel 1 [list a $i]
- }
+ proc a i [makebody {uplevel 1 [list a $i]}]
} -body {
+ setabs
a 0
} -cleanup {
rename a {}
-} -result {0 2 2 0}
+ unset abs
+} -result {{0 2 2 0} 0}
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"
- }
+ setabs
+ proc a i [makebody {uplevel 1 "set x $i; a $i"}]
} -body {
- list [catch {a 0} msg] $msg
+ a 0
} -cleanup {
rename a {}
-} -result {0 20001}
+ unset abs
+} -result {{0 2 2 0} 0}
test NRE-7.1 {[catch] is not recursive} -setup {
- proc a i {
- variable x [depthDiff]
- if {[incr i] > 10} {
- return
- }
- uplevel 1 [list catch "a $i"]
- }
+ setabs
+ proc a i [makebody {uplevel 1 "catch {a $i} msg; set msg"}]
} -body {
- catch {a 0}
- lrange $x 0 3
+ a 0
} -cleanup {
rename a {}
- unset x
-} -result {0 3 3 0}
-
+ unset x abs
+} -result {{0 3 3 0} 0}
#
# Basic TclOO tests
@@ -308,86 +199,67 @@ test NRE-7.1 {[catch] is not recursive} -setup {
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
- }
+ oo::objdefine foo method bar i [makebody {foo bar $i}]
} -body {
+ setabs
foo bar 0
} -cleanup {
foo destroy
-} -result 20001
+ 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 {
- if {[incr i] > 20000} {
- return $i
- }
- [self] bar $i
- }
+ oo::objdefine foo method bar i [makebody {[self] bar $i}]
} -body {
+ setabs
foo bar 0
} -cleanup {
foo destroy
-} -result 20001
+ 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 {
- if {[incr i] > 20000} {
- return $i
- }
- my bar $i
- }
+ oo::objdefine foo method bar i [makebody {my bar $i}]
} -body {
+ setabs
foo bar 0
} -cleanup {
foo destroy
-} -result 20001
+ 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 {
- if {[incr i] > 20000} {
- return $i
- }
- my bar $i
- }
+ method bar i [makebody {my bar $i}]
}
oo::class create boo {
superclass foo
- method bar i {
- if {[incr i] > 20000} {
- return $i
- }
- next $i
- }
+ method bar i [makebody {next $i}]
}
} -body {
+ setabs
[boo new] bar 0
} -cleanup {
foo destroy
-} -result 20001
+ unset abs
+} -result {{0 1 1 1} 0}
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
- }
+ 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
-} -result 20001
+ unset abs
+} -result {{0 2 1 1} 0}
#
@@ -414,8 +286,11 @@ test NRE-X.1 {eval in wrong interp} {
#
# Test tailcalls
#
-namespace eval tcl::unsupported namespace export tailcall
-namespace import tcl::unsupported::tailcall
+
+if {[testConstraint tailcall]} {
+ namespace eval tcl::unsupported namespace export tailcall
+ namespace import tcl::unsupported::tailcall
+}
test NRE-T.0 {tailcall is constant space} -constraints {tailcall} -setup {
proc a i {
@@ -579,6 +454,7 @@ test NRE-T.9 {tailcall factorial} -constraints {tailcall} -setup {
namespace forget tcl::unsupported::tailcall
+
#
# Test that ensembles are non-recursive
#
@@ -588,13 +464,13 @@ namespace forget tcl::unsupported::tailcall
# cleanup
::tcltest::cleanupTests
-interp recursionlimit {} $oldRecursionLimit
-unset oldRecursionLimit
+if {[testConstraint testnrelevels]} {
+ namespace forget testnre::*
+ namespace delete testnre
+}
-if {[testConstraint teststacklimit]} {
- teststacklimit $oldLimit
- unset oldLimit
+if {[testConstraint tailcall]} {
+ namespace forget tcl::unsupported::tailcall
}
-namespace delete testnre
return