Combine UpdateClassDelegatesAfterClone into its caller. (backport)

2 files changed, 30 insertions, 45 deletions

diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 79379d3..0bec4fa 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -27,20 +27,6 @@
 static const char *tclOOSetupScript =
 /* !BEGIN!: Do not edit below this line. */
 "::namespace eval ::oo {\n"
-"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
-"\t\tset originDelegate [DelegateName $originObject]\n"
-"\t\tset targetDelegate [DelegateName $targetObject]\n"
-"\t\tif {\n"
-"\t\t\t[info object isa class $originDelegate]\n"
-"\t\t\t&& ![info object isa class $targetDelegate]\n"
-"\t\t} then {\n"
-"\t\t\tcopy $originDelegate $targetDelegate\n"
-"\t\t\tobjdefine $targetObject ::oo::objdefine::mixin -set \\\n"
-"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n"
-"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n"
-"\t\t\t\t}]\n"
-"\t\t}\n"
-"\t}\n"
 "\tdefine Slot forward --default-operation my -append\n"
 "\tdefine Slot unexport destroy\n"
 "\tobjdefine define::superclass forward --default-operation my -set\n"
@@ -74,8 +60,20 @@ static const char *tclOOSetupScript =
 "\t\t}\n"
 "\t}\n"
 "\tdefine class method <cloned> -unexport {originObject} {\n"
+"\t\tset targetObject [self]\n"
 "\t\tnext $originObject\n"
-"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
+"\t\tset originDelegate [::oo::DelegateName $originObject]\n"
+"\t\tset targetDelegate [::oo::DelegateName $targetObject]\n"
+"\t\tif {\n"
+"\t\t\t[info object isa class $originDelegate]\n"
+"\t\t\t&& ![info object isa class $targetDelegate]\n"
+"\t\t} then {\n"
+"\t\t\t::oo::copy $originDelegate $targetDelegate\n"
+"\t\t\t::oo::objdefine $targetObject mixin -set \\\n"
+"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n"
+"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n"
+"\t\t\t\t}]\n"
+"\t\t}\n"
 "\t}\n"
 "\tclass create singleton\n"
 "\tdefine singleton superclass -set class\n"
@@ -86,11 +84,11 @@ static const char *tclOOSetupScript =
 "\t\t\tset object [next {*}$args]\n"
 "\t\t\t::oo::objdefine $object {\n"
 "\t\t\t\tmethod destroy {} {\n"
-"\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n"
+"\t\t\t\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n"
 "\t\t\t\t\t\t\"may not destroy a singleton object\"\n"
 "\t\t\t\t}\n"
 "\t\t\t\tmethod <cloned> -unexport {originObject} {\n"
-"\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n"
+"\t\t\t\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n"
 "\t\t\t\t\t\t\"may not clone a singleton object\"\n"
 "\t\t\t\t}\n"
 "\t\t\t}\n"
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 8bb214a..d871d57 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -14,31 +14,6 @@
 ::namespace eval ::oo {
     # ----------------------------------------------------------------------
     #
-    # UpdateClassDelegatesAfterClone --
-    #
-    #	Support code that is like [MixinClassDelegates] except for when a
-    #	class is cloned.
-    #
-    # ----------------------------------------------------------------------
-
-    proc UpdateClassDelegatesAfterClone {originObject targetObject} {
-	# Rebuild the class inheritance delegation class
-	set originDelegate [DelegateName $originObject]
-	set targetDelegate [DelegateName $targetObject]
-	if {
-	    [info object isa class $originDelegate]
-	    && ![info object isa class $targetDelegate]
-	} then {
-	    copy $originDelegate $targetDelegate
-	    objdefine $targetObject ::oo::objdefine::mixin -set \
-		{*}[lmap c [info object mixin $targetObject] {
-		    if {$c eq $originDelegate} {set targetDelegate} {set c}
-		}]
-	}
-    }
-
-    # ----------------------------------------------------------------------
-    #
     # Slot --
     #
     #	The class of slot operations, which are basically lists at the low
@@ -116,9 +91,21 @@
     # ----------------------------------------------------------------------
 
     define class method <cloned> -unexport {originObject} {
+	set targetObject [self]
 	next $originObject
 	# Rebuild the class inheritance delegation class
-	::oo::UpdateClassDelegatesAfterClone $originObject [self]
+	set originDelegate [::oo::DelegateName $originObject]
+	set targetDelegate [::oo::DelegateName $targetObject]
+	if {
+	    [info object isa class $originDelegate]
+	    && ![info object isa class $targetDelegate]
+	} then {
+	    ::oo::copy $originDelegate $targetDelegate
+	    ::oo::objdefine $targetObject mixin -set \
+		{*}[lmap c [info object mixin $targetObject] {
+		    if {$c eq $originDelegate} {set targetDelegate} {set c}
+		}]
+	}
     }
 
     # ----------------------------------------------------------------------
@@ -139,11 +126,11 @@
 	    set object [next {*}$args]
 	    ::oo::objdefine $object {
 		method destroy {} {
-		    ::return -code error -errorcode {TCL OO SINGLETON} \
+		    return -code error -errorcode {TCL OO SINGLETON} \
 			"may not destroy a singleton object"
 		}
 		method <cloned> -unexport {originObject} {
-		    ::return -code error -errorcode {TCL OO SINGLETON} \
+		    return -code error -errorcode {TCL OO SINGLETON} \
 			"may not clone a singleton object"
 		}
 	    }