Make the delegates work by moving their creation into C.

2 files changed, 37 insertions, 41 deletions

diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 763f0ad..54115e0 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -83,7 +83,7 @@ TclOO_Class_Constructor(
     Tcl_Obj *const *objv)
 {
     Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
-    Tcl_Obj **invoke;
+    Tcl_Obj **invoke, *nameObj;
 
     if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) {
 	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
@@ -94,6 +94,17 @@ TclOO_Class_Constructor(
     }
 
     /*
+     * Make the class definition delegate. This is special; it doesn't reenter
+     * here (and the class definition delegate doesn't run any constructors).
+     */
+
+    nameObj = Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1);
+    Tcl_AppendToObj(nameObj, ":: oo ::delegate", -1);
+    Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls,
+	    TclGetString(nameObj), NULL, -1, NULL, -1);
+    Tcl_DecrRefCount(nameObj);
+
+    /*
      * Delegate to [oo::define] to do the work.
      */
 
@@ -128,12 +139,17 @@ DecrRefsPostClassConstructor(
     int result)
 {
     Tcl_Obj **invoke = data[0];
+    Tcl_InterpState saved;
 
     TclDecrRefCount(invoke[0]);
-    TclDecrRefCount(invoke[1]);
     TclDecrRefCount(invoke[2]);
+    invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", -1);
+    Tcl_IncrRefCount(invoke[0]);
+    saved = Tcl_SaveInterpState(interp, result);
+    Tcl_EvalObjv(interp, 2, invoke, 0);
+    TclDecrRefCount(invoke[1]);
     ckfree(invoke);
-    return result;
+    return Tcl_RestoreInterpState(interp, saved);
 }
 
 /*
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"