Make the delegates work by moving their creation into C.

1 files changed, 18 insertions, 38 deletions

diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 4ca286c..102f2a2 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -5,7 +5,9 @@
  *	that the code can be definitely run even in safe interpreters; TclOO's
  *	core setup is safe.
  *
- * Copyright (c) 2012-2018 by Donal K. Fellows
+ * Copyright (c) 2012-2018 Donal K. Fellows
+ * Copyright (c) 2013 Andreas Kupries
+ * Copyright (c) 2017 Gerald Lester
  *
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -51,6 +53,10 @@ static const char *tclOOSetupScript =
 "    return\n"
 "}\n"
 
+"proc ::oo::DelegateName {class} {\n"
+"    string cat [info object namespace $class] {:: oo ::delegate}\n"
+"}\n"
+
 "proc ::oo::define::classmethod {name {args {}} {body {}}} {\n"
 "    # Create the method on the class if the caller gave arguments and body\n"
 "    set argc [llength [info level 0]]\n"
@@ -59,46 +65,24 @@ static const char *tclOOSetupScript =
 "                [lindex [info level 0] 0] { name ?args body?\"}]\n"
 "    }\n"
 "    set cls [uplevel 1 self]\n"
-/*
-"    set d $cls.Delegate\n"
-"    if {[info object isa object $d] && [info object isa class $d]} {\n"
-"        set cls $d\n"
-"    }\n"
-*/
 "    if {$argc == 4} {\n"
-"        ::oo::define $cls method $name $args $body\n"
+"        ::oo::define [::oo::DelegateName $cls] method $name $args $body\n"
 "    }\n"
 "    # Make the connection by forwarding\n"
 "    tailcall forward $name [info object namespace $cls]::my $name\n"
 "}\n"
 
-/*
-"# Build this *almost* like a class method, but with extra care to avoid\n"
-"# nuking the existing method.\n"
-"::oo::class create ::oo::class.Delegate {\n"
-"    method create {name args} {\n"
-"        if {![string match ::* $name]} {\n"
-"            set ns [uplevel 1 {namespace current}]\n"
-"            if {$ns eq {::}} {set ns {}}\n"
-"            set name ${ns}::${name}\n"
-"        }\n"
-"        if {[string match *.Delegate $name]} {\n"
-"            return [next $name {*}$args]\n"
-"        }\n"
-"        set delegate [oo::class create $name.Delegate]\n"
-"        set cls [next $name {*}$args]\n"
-"        set superdelegates [list $delegate]\n"
-"        foreach c [info class superclass $cls] {\n"
-"            set d $c.Delegate\n"
-"            if {[info object isa object $d] && [info object isa class $d]} {\n"
-"                lappend superdelegates $d\n"
-"            }\n"
-"        }\n"
-"        oo::objdefine $cls mixin {*}$superdelegates\n"
-"        return $cls\n"
-"    }\n"
+"proc ::oo::MixinClassDelegates {class} {\n"
+"    ::oo::objdefine $class mixin -append {*}[lmap c [info class superclass $class] {\n"
+"        set d [::oo::DelegateName $c]\n"
+"        if {![info object isa class $d]} continue; set d\n"
+"    }]\n"
+"}\n"
+
+"::proc ::oo::define::initialise {body} {\n"
+"    set clsns [info object namespace [uplevel 1 self]]\n"
+"    tailcall apply [list {} $body $clsns]\n"
 "}\n"
-*/
 
 "::oo::define ::oo::Slot {\n"
 "    method Get {} {return -code error unimplemented}\n"
@@ -130,10 +114,6 @@ static const char *tclOOSetupScript =
 "::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n"
 "::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n"
 
-/*
-"::oo::define ::oo::class self mixin ::oo::class.Delegate\n"
-*/
-
 "::oo::class create ::oo::singleton {\n"
 "    superclass ::oo::class\n"
 "    variable object\n"