Accelerate definition of [oo::define initialise]. (backport)

6 files changed, 52 insertions, 45 deletions

diff --git a/generic/tclOO.c b/generic/tclOO.c
index 09071e6..a4c4da1 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -31,6 +31,8 @@ static const struct {
     {"destructor", TclOODefineDestructorObjCmd, 0},
     {"export", TclOODefineExportObjCmd, 0},
     {"forward", TclOODefineForwardObjCmd, 0},
+    {"initialise", TclOODefineInitialiseObjCmd, 0},
+    {"initialize", TclOODefineInitialiseObjCmd, 0},
     {"method", TclOODefineMethodObjCmd, 0},
     {"private", TclOODefinePrivateObjCmd, 0},
     {"renamemethod", TclOODefineRenameMethodObjCmd, 0},
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index e029649..5b6de0e 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -2032,6 +2032,53 @@ TclOODefineForwardObjCmd(
 /*
  * ----------------------------------------------------------------------
  *
+ * TclOODefineInitialiseObjCmd --
+ *
+ *	Implementation of the "initialise" subcommand of the "oo::define"
+ *	command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineInitialiseObjCmd(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Tcl_Object object;
+    Tcl_Obj *lambdaWords[3], *applyArgs[2];
+    int result;
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "body");
+	return TCL_ERROR;
+    }
+
+    // Build the lambda
+    object = TclOOGetDefineCmdContext(interp);
+    if (object == NULL) {
+	return TCL_ERROR;
+    }
+    lambdaWords[0] = Tcl_NewObj();
+    lambdaWords[1] = objv[1];
+    lambdaWords[2] = TclNewNamespaceObj(Tcl_GetObjectNamespace(object));
+
+    // Delegate to [apply] to run it
+    applyArgs[0] = Tcl_NewStringObj("apply", -1);
+    applyArgs[1] = Tcl_NewListObj(3, lambdaWords);
+    Tcl_IncrRefCount(applyArgs[0]);
+    Tcl_IncrRefCount(applyArgs[1]);
+    result = Tcl_ApplyObjCmd(NULL, interp, 2, applyArgs);
+    Tcl_DecrRefCount(applyArgs[0]);
+    Tcl_DecrRefCount(applyArgs[1]);
+    return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * TclOODefineMethodObjCmd --
  *
  *	Implementation of the "method" subcommand of the "oo::define" and
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 4e7d4d0..59a0cb6 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -504,6 +504,7 @@ MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineDeleteMethodObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineDestructorObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineExportObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineForwardObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineInitialiseObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineMethodObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineRenameMethodObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineUnexportObjCmd;
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 50d827f..ff29535 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -121,17 +121,6 @@ static const char *tclOOSetupScript =
 "\t\t}\n"
 "\t\t::tailcall forward $name myclass $name\n"
 "\t}\n"
-"\tproc define::initialise {body} {\n"
-"\t\t::set clsns [::info object namespace [::uplevel 1 self]]\n"
-"\t\t::tailcall apply [::list {} $body $clsns]\n"
-"\t}\n"
-"\tnamespace eval define {\n"
-"\t\t::namespace export initialise\n"
-"\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n"
-"\t\t::namespace export -clear\n"
-"\t\t::rename tmp::initialise initialize\n"
-"\t\t::namespace delete tmp\n"
-"\t}\n"
 "\tdefine Slot {\n"
 "\t\tmethod Get -unexport {} {\n"
 "\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n"
diff --git a/tests/ooUtil.test b/tests/ooUtil.test
index 20607b0..5a8a25b 100644
--- a/tests/ooUtil.test
+++ b/tests/ooUtil.test
@@ -366,7 +366,7 @@ test ooUtil-3.4 {TIP 478: class initialisation} -setup {
     trace add execution oo::define::initialise enter appendToResultVar
     oo::class create ::cls {
 	superclass parent
-	initialize {proc xyzzy {} {}}
+	initialise {proc xyzzy {} {}}
     }
     return $result
 } -cleanup {
@@ -375,13 +375,7 @@ test ooUtil-3.4 {TIP 478: class initialisation} -setup {
     }
     rename ::appendToResultVar {}
     parent destroy
-} -result {{initialize {proc xyzzy {} {}}} enter}
-test ooUtil-3.5 {TIP 478: class initialisation} -body {
-    oo::define oo::object {
-	::list [::namespace which initialise] [::namespace which initialize] \
-	     [::namespace origin initialise] [::namespace origin initialize]
-    }
-} -result {::oo::define::initialise ::oo::define::initialize ::oo::define::initialise ::oo::define::initialise}
+} -result {{initialise {proc xyzzy {} {}}} enter}
 
 test ooUtil-4.1 {TIP 478: singleton} -setup {
     oo::class create parent
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index cb77bb3..b60542f 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -193,32 +193,6 @@
 
     # ----------------------------------------------------------------------
     #
-    # oo::define::initialise, oo::define::initialize --
-    #
-    #	Do specific initialisation for a class. See define(n) for details.
-    #
-    # Note that the ::oo::define namespace is semi-public and a bit weird
-    # anyway, so we don't regard the namespace path as being under control:
-    # fully qualified names are used for everything.
-    #
-    # ----------------------------------------------------------------------
-
-    proc define::initialise {body} {
-	::set clsns [::info object namespace [::uplevel 1 self]]
-	::tailcall apply [::list {} $body $clsns]
-    }
-
-    # Make the [initialise] definition appear as [initialize] too
-    namespace eval define {
-	::namespace export initialise
-	::namespace eval tmp {::namespace import ::oo::define::initialise}
-	::namespace export -clear
-	::rename tmp::initialise initialize
-	::namespace delete tmp
-    }
-
-    # ----------------------------------------------------------------------
-    #
     # Slot --
     #
     #	The class of slot operations, which are basically lists at the low