diff options
| -rw-r--r-- | generic/tclExecute.c | 1 | ||||
| -rw-r--r-- | tests/ooNext2.test | 190 |
2 files changed, 191 insertions, 0 deletions
diff --git a/generic/tclExecute.c b/generic/tclExecute.c index f2f475a..43c2b08 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4946,6 +4946,7 @@ TEBCresume( pc += pcAdjustment; TEBC_YIELD(); + TclPushTailcallPoint(interp); oPtr = contextPtr->oPtr; if (oPtr->flags & FILTER_HANDLING) { TclNRAddCallback(interp, FinalizeOONextFilter, diff --git a/tests/ooNext2.test b/tests/ooNext2.test index 5ecd209..6a48d28 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -866,6 +866,196 @@ test oo-call-3.4 {current call introspection: in destructors} -setup { } -cleanup { root destroy } -result {{{{method <destructor> ::B method} {method <destructor> ::A method}} 0} {{{method <destructor> ::B method} {method <destructor> ::A method}} 1}} + +# Contributed tests from aspect, related to [0f42ff7871] +# +# dkf's "Principles Leading to a Fix" +# +# A method ought to work "the same" whether or not it has been overridden by +# a subclass. A tailcalled command ought to have as parent stack the same +# thing you'd get with uplevel 1. A subclass will often expect the +# superclass's result to be the result that would be returned if the +# subclass was not there. + +# Common setup: +# any invocation of bar should emit "abc\nhi\n" then return to its +# caller +set testopts { + -setup { + oo::class create Master + oo::class create Foo { + superclass Master + method bar {} { + puts abc + tailcall puts hi + puts xyz + } + } + oo::class create Foo2 { + superclass Master + } + } + -cleanup { + Master destroy + } +} + +# these succeed, showing that without [next] the bug doesn't fire +test next-tailcall-simple-1 "trivial case with one method" {*}$testopts -body { + [Foo create foo] bar +} -output [join {abc hi} \n]\n +test next-tailcall-simple-2 "my bar" {*}$testopts -body { + oo::define Foo method baz {} { + puts a + my bar + puts b + } + [Foo create foo] baz +} -output [join {a abc hi b} \n]\n +test next-tailcall-simple-3 "\[self\] bar" {*}$testopts -body { + oo::define Foo method baz {} { + puts a + [self] bar + puts b + } + [Foo create foo] baz +} -output [join {a abc hi b} \n]\n +test next-tailcall-simple-4 "foo bar" {*}$testopts -body { + oo::define Foo method baz {} { + puts a + foo bar + puts b + } + [Foo create foo] baz +} -output [join {a abc hi b} \n]\n + +# everything from here on uses [next], and fails on 8.6.4 with compilation +test next-tailcall-superclass-1 "next superclass" {*}$testopts -body { + oo::define Foo2 { + superclass Foo + method bar {} { + puts a + next + puts b + } + } + [Foo2 create foo] bar +} -output [join {a abc hi b} \n]\n +test next-tailcall-superclass-2 "nextto superclass" {*}$testopts -body { + oo::define Foo2 { + superclass Foo + method bar {} { + puts a + nextto Foo + puts b + } + } + [Foo2 create foo] bar +} -output [join {a abc hi b} \n]\n + +test next-tailcall-mixin-1 "class mixin" {*}$testopts -body { + oo::define Foo2 { + method Bar {} { + puts a + next + puts b + } + filter Bar + } + oo::define Foo mixin Foo2 + Foo create foo + foo bar +} -output [join {a abc hi b} \n]\n + +test next-tailcall-objmixin-1 "object mixin" {*}$testopts -body { + oo::define Foo2 { + method Bar {} { + puts a + next + puts b + } + filter Bar + } + Foo create foo + oo::objdefine foo mixin Foo2 + foo bar +} -output [join {a abc hi b} \n]\n + +test next-tailcall-filter-1 "filter method" {*}$testopts -body { + oo::define Foo method Filter {} { + puts a + next + puts b + } + oo::define Foo filter Filter + [Foo new] bar +} -output [join {a abc hi b} \n]\n + +test next-tailcall-forward-1 "forward method" {*}$testopts -body { + proc foobar {} { + puts "abc" + tailcall puts "hi" + puts "xyz" + } + oo::define Foo forward foobar foobar + oo::define Foo2 { + superclass Foo + method foobar {} { + puts a + next + puts b + } + } + [Foo2 new] foobar +} -output [join {a abc hi b} \n]\n + +test next-tailcall-constructor-1 "next in constructor" -body { + oo::class create Foo { + constructor {} { + puts abc + tailcall puts hi + puts xyz + } + } + oo::class create Foo2 { + superclass Foo + constructor {} { + puts a + next + puts b + } + } + list [Foo new] [Foo2 new] + return "" +} -cleanup { + Foo destroy +} -output [join {abc hi a abc hi b} \n]\n + +test next-tailcall-destructor-1 "next in destructor" -body { + oo::class create Foo { + destructor { + puts abc + tailcall puts hi + puts xyz + } + } + oo::class create Foo2 { + superclass Foo + destructor { + puts a + next + puts b + } + } + Foo create foo + Foo2 create foo2 + foo destroy + foo2 destroy +} -output [join {abc hi a abc hi b} \n]\n -cleanup { + Foo destroy +} + +unset testopts cleanupTests return |