merge trunk

1 files changed, 278 insertions, 1 deletions

diff --git a/tests/ooNext2.test b/tests/ooNext2.test
index a47aa91..6a48d28 100644
--- a/tests/ooNext2.test
+++ b/tests/ooNext2.test
@@ -7,7 +7,7 @@
 # See the file "license.terms" for information on usage and redistribution of
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
-package require TclOO 1.0.1
+package require TclOO 1.0.3
 package require tcltest 2
 if {"::tcltest" in [namespace children]} {
     namespace import -force ::tcltest::*
@@ -526,6 +526,93 @@ test oo-call-1.19 {object call introspection - memory leaks} -setup {
 } -cleanup {
     leaktester destroy
 } -constraints memory -result 0
+test oo-call-1.20 {object call introspection - complex case} -setup {
+    oo::class create root
+} -body {
+    oo::class create ::A {
+	superclass root
+	method x {} {}
+    }
+    oo::class create ::B {
+	superclass A
+	method x {} {}
+    }
+    oo::class create ::C {
+	superclass root
+	method x {} {}
+	mixin B
+    }
+    oo::class create ::D {
+	superclass C
+	method x {} {}
+    }
+    oo::class create ::E {
+	superclass root
+	method x {} {}
+    }
+    oo::class create ::F {
+	superclass E
+	method x {} {}
+    }
+    oo::class create ::G {
+	superclass root
+	method x {} {}
+    }
+    oo::class create ::H {
+	superclass G
+	method x {} {}
+    }
+    oo::define F mixin H
+    F create y
+    oo::objdefine y {
+	method x {} {}
+	mixin D
+    }
+    info object call y x
+} -cleanup {
+    root destroy
+} -result {{method x ::D method} {method x ::B method} {method x ::A method} {method x ::C method} {method x ::H method} {method x ::G method} {method x object method} {method x ::F method} {method x ::E method}}
+test oo-call-1.21 {object call introspection - complex case} -setup {
+    oo::class create root
+} -body {
+    oo::class create ::A {
+	superclass root
+	method y {} {}
+	filter y
+    }
+    oo::class create ::B {
+	superclass A
+	method y {} {}
+    }
+    oo::class create ::C {
+	superclass root
+	method x {} {}
+	mixin B
+    }
+    oo::class create ::D {
+	superclass C
+	filter x
+    }
+    oo::class create ::E {
+	superclass root
+	method y {} {}
+	method x {} {}
+    }
+    oo::class create ::F {
+	superclass E
+	method z {} {}
+	method q {} {}
+    }
+    F create y
+    oo::objdefine y {
+	method unknown {} {}
+	mixin D
+	filter q
+    }
+    info object call y z
+} -cleanup {
+    root destroy
+} -result {{filter x ::C method} {filter x ::E method} {filter y ::B method} {filter y ::A method} {filter y ::E method} {filter q ::F method} {method z ::F method}}
 
 test oo-call-2.1 {class call introspection} -setup {
     oo::class create root
@@ -779,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