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

4 files changed, 50 insertions, 11 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"