-- 
cgit v0.12

From 1528383bf15f7ce614cbb3c2762aeaadebee13fd Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Mon, 14 Jul 2025 15:31:08 +0000
Subject: Backout [816e9ddf1b]: TclVarHashCreateVar() is still used in Itcl

---
 generic/tclInt.decls  | 3 ++-
 generic/tclIntDecls.h | 9 ++-------
 generic/tclStubInit.c | 1 -
 generic/tclVar.c      | 2 --
 4 files changed, 4 insertions(+), 11 deletions(-)

diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 84fac97..1fd54b9 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -529,7 +529,8 @@ declare 233 {
     void TclGetSrcInfoForPc(CmdFrame *contextPtr)
 }
 
-declare 234 {deprecated {Not used in Tcl, not in any extension any more}} {
+# Exports for VarReform compat: Itcl, XOTcl like to peek into our varTables :(
+declare 234 {
     Var *TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key,
 	    int *newPtr)
 }
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 5dae6d1..232e987 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -491,8 +491,7 @@ EXTERN int		TclEvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr,
 /* 233 */
 EXTERN void		TclGetSrcInfoForPc(CmdFrame *contextPtr);
 /* 234 */
-TCL_DEPRECATED("Not used in Tcl, not in any extension any more")
-Var *			TclVarHashCreateVar(TclVarHashTable *tablePtr,
+EXTERN Var *		TclVarHashCreateVar(TclVarHashTable *tablePtr,
 				const char *key, int *newPtr);
 /* 235 */
 EXTERN void		TclInitVarHashTable(TclVarHashTable *tablePtr,
@@ -815,7 +814,7 @@ typedef struct TclIntStubs {
     int (*tclGetNamespaceFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); /* 231 */
     int (*tclEvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 232 */
     void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */
-    TCL_DEPRECATED_API("Not used in Tcl, not in any extension any more") Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */
+    Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */
     void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */
     void (*reserved236)(void);
     int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */
@@ -1275,10 +1274,6 @@ extern const TclIntStubs *tclIntStubsPtr;
 #define TclObjInterpProc TclGetObjInterpProc()
 #define TclObjInterpProc2 TclGetObjInterpProc2()
 
-#ifdef TCL_NO_DEPRECATED
-#   undef TclVarHashCreateVar
-#endif
-
 #undef TCL_STORAGE_CLASS
 #define TCL_STORAGE_CLASS DLLIMPORT
 
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 6afa675..7793df8 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -61,7 +61,6 @@
 # define TclGetStringFromObj 0
 # define TclGetBytesFromObj 0
 # define TclGetUnicodeFromObj 0
-# define TclVarHashCreateVar 0
 #endif
 #undef Tcl_Close
 #define Tcl_Close 0
diff --git a/generic/tclVar.c b/generic/tclVar.c
index c337cc3..c41e12c 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -308,7 +308,6 @@ static const Tcl_ObjType parsedVarNameType = {
 	(elem) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr2 : NULL;	\
     } while (0)
 
-#ifndef TCL_NO_DEPRECATED
 Var *
 TclVarHashCreateVar(
     TclVarHashTable *tablePtr,
@@ -325,7 +324,6 @@ TclVarHashCreateVar(
 
     return varPtr;
 }
-#endif
 
 static int
 LocateArray(
-- 
cgit v0.12


From f4a5ba54ac8ef6b91dab487da95dc3bc5af762e2 Mon Sep 17 00:00:00 2001
From: apnadkarni <apnmbx-wits@yahoo.com>
Date: Tue, 15 Jul 2025 02:31:28 +0000
Subject: Fix [25265a2705] - dup test names in listTypes.test

---
 tests/listTypes.test | 12 ++++++------
 1 file changed, 6 insertions(+), 6 deletions(-)

diff --git a/tests/listTypes.test b/tests/listTypes.test
index d588c56..482dd76 100644
--- a/tests/listTypes.test
+++ b/tests/listTypes.test
@@ -352,13 +352,13 @@ namespace eval listtype {
                                               {0 -1 0} {} \
                                               [list 0 $largeListLength 0] {} \
                 ] {
-                    testdef lindex-nested-onearg-$ltype1-$ltype2-$ltype3 "lindex nested single indices argument $ltype1 $ltype2 $ltype3 $indices" \
+                    testdef lindex-nested-onearg-$ltype1-$ltype2-$ltype3-[join $indices ,] "lindex nested single indices argument $ltype1 $ltype2 $ltype3 $indices" \
                         -body {
                             variable indices
                             lindex [makeNestedList $ltype1 $ltype2 $ltype3] $indices
                         } -result $result
 
-                    testdef lindex-nested-multiarg-$ltype1-$ltype2-$ltype3 "lindex nested multiple index arguments $ltype1 $ltype2 $ltype3 $indices" \
+                    testdef lindex-nested-multiarg-$ltype1-$ltype2-$ltype3-[join $indices ,] "lindex nested multiple index arguments $ltype1 $ltype2 $ltype3 $indices" \
                         -body {
                             variable indices
                             lindex [makeNestedList $ltype1 $ltype2 $ltype3] {*}$indices
@@ -708,12 +708,12 @@ namespace eval listtype {
             # TODO - consider changing lsort to not shimmer its argument.
             list [isAbstractList $l] $l $l2
         } -result [list 0 [lsort [makeNonAbstract [makeList $ltype]]] [makeList $ltype]]
-        testdef lsort-$ltype-unshared "lsort -decreasing unshared $ltype" -body {
+        testdef lsort-$ltype-unshared-decreasing "lsort -decreasing unshared $ltype" -body {
             set l [lsort -decreasing [makeList $ltype]]
             list [isAbstractList $l] $l
         } -result [list 0 [lsort -decreasing [makeNonAbstract [makeList $ltype]]]]
 
-        testdef lsort-$ltype-shared "lsort unshared $ltype" -body {
+        testdef lsort-$ltype-shared-decreasing "lsort unshared $ltype" -body {
             set l2 [makeList $ltype]
             set l [lsort -decreasing $l2]
             # Note: $l2 is shimmered by lsort.
@@ -1216,7 +1216,7 @@ namespace eval listtype {
         }
     }
     foreach nrefs {0 1 2} {
-        test Tcl_ListObjRange-invalid-list {
+        test Tcl_ListObjRange-invalid-list-$nrefs {
             Invalid list should return NULL in resultPtr
         } -body {
             set apiresult [testlistapi Tcl_ListObjRange $nrefs \{ 0 0]
@@ -1293,7 +1293,7 @@ namespace eval listtype {
         }
     }
     foreach nrefs {0 1 2} {
-        test Tcl_ListObjReverse-invalid-list {
+        test Tcl_ListObjReverse-invalid-list-$nrefs {
             Invalid list should return NULL in resultPtr
         } -body {
             set apiresult [testlistapi Tcl_ListObjReverse $nrefs \{]
-- 
cgit v0.12


From 78cb74134b6280229cd2fbe3dc00f21aa6ec5b23 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Thu, 17 Jul 2025 07:59:16 +0000
Subject: Fix installation of dde/registry packages (Thanks, Harald, for
 noticing this!)

---
 win/makefile.vc | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/win/makefile.vc b/win/makefile.vc
index 7d5ad91..547a00c 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -209,10 +209,10 @@ TCL_TEST_LIBRARY=
 
 !include versions.vc
 
-DDEDOTVERSION = 1.4
+DDEDOTVERSION = 1.5
 DDEVERSION = $(DDEDOTVERSION:.=)
 
-REGDOTVERSION = 1.3
+REGDOTVERSION = 1.4
 REGVERSION = $(REGDOTVERSION:.=)
 
 TCLREGLIBNAME	= $(PROJECT)9registry$(REGVERSION)$(SUFX:t=).$(EXT)
-- 
cgit v0.12


From 9feb99ecb11ac1b97c49dd3919599c6575f58abe Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Fri, 18 Jul 2025 07:37:28 +0000
Subject: Fix 2 warnings on 32-bit platform (thanks, Emiliano)

---
 generic/tclAssembly.c | 2 +-
 generic/tclExecute.c  | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 2ca5460..7f5a257 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -2055,7 +2055,7 @@ CreateMirrorNumJumpTable(
 	    }
 	    goto error;
 	}
-	hPtr = Tcl_CreateHashEntry(&jtnPtr->hashTable, (void*)key, &isNew);
+	hPtr = Tcl_CreateHashEntry(&jtnPtr->hashTable, INT2PTR(key), &isNew);
 	if (!isNew) {
 	    if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
 		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index d7dbaaa..53c807b 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4665,7 +4665,7 @@ TEBCresume(
 	if (Tcl_GetWideIntFromObj(NULL, OBJ_AT_TOS, &key) != TCL_OK) {
 	    goto jumpTableNumFallthrough;
 	}
-	hPtr = Tcl_FindHashEntry(&jtnPtr->hashTable, (void *)key);
+	hPtr = Tcl_FindHashEntry(&jtnPtr->hashTable, INT2PTR(key));
 
     processJumpTableEntry:
 	if (hPtr != NULL) {
-- 
cgit v0.12


From e499be71f08bcbd95d66b832db9ede94afcf41b7 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Fri, 18 Jul 2025 09:52:12 +0000
Subject: Add check for working --disable-high-entropy-va. Fix check for
 --enable-auto-image-base (which always succeeded)

---
 win/configure | 45 ++++++++++++++++++++++++++++++++++++++++++---
 win/tcl.m4    | 14 ++++++++++++--
 2 files changed, 54 insertions(+), 5 deletions(-)

diff --git a/win/configure b/win/configure
index 2549e63..1c270750 100755
--- a/win/configure
+++ b/win/configure
@@ -4198,7 +4198,7 @@ printf "%s\n" "yes" >&6; }
 
     if test "${GCC}" = "yes" ; then
 	extra_cflags="-pipe"
-	extra_ldflags="-pipe -static-libgcc -Wl,--disable-high-entropy-va"
+	extra_ldflags="-pipe -static-libgcc"
 	{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for mingw32 version of gcc" >&5
 printf %s "checking for mingw32 version of gcc... " >&6; }
 if test ${ac_cv_win32+y}
@@ -4366,6 +4366,44 @@ printf "%s\n" "$ac_cv_nolto" >&6; }
 	else
 	    CFLAGS_NOLTO=""
 	fi
+
+	{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if the linker understands --disable-high-entropy-va" >&5
+printf %s "checking if the linker understands --disable-high-entropy-va... " >&6; }
+if test ${tcl_cv_ld_high_entropy+y}
+then :
+  printf %s "(cached) " >&6
+else case e in #(
+  e)
+	    hold_cflags=$CFLAGS; CFLAGS="$CFLAGS  -Wl,--disable-high-entropy-va"
+	    cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h.  */
+
+int
+main (void)
+{
+
+  ;
+  return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"
+then :
+  tcl_cv_ld_high_entropy=yes
+else case e in #(
+  e) tcl_cv_ld_high_entropy=no ;;
+esac
+fi
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+    conftest$ac_exeext conftest.$ac_ext
+	    CFLAGS=$hold_cflags ;;
+esac
+fi
+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_ld_high_entropy" >&5
+printf "%s\n" "$tcl_cv_ld_high_entropy" >&6; }
+	if test $tcl_cv_ld_high_entropy = yes; then
+	    extra_ldflags="$extra_ldflags -Wl,--disable-high-entropy-va"
+	fi
+
 	{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking if the compiler understands -finput-charset" >&5
 printf %s "checking if the compiler understands -finput-charset... " >&6; }
 if test ${tcl_cv_cc_input_charset+y}
@@ -4421,14 +4459,15 @@ main (void)
   return 0;
 }
 _ACEOF
-if ac_fn_c_try_compile "$LINENO"
+if ac_fn_c_try_link "$LINENO"
 then :
   ac_cv_enable_auto_image_base=yes
 else case e in #(
   e) ac_cv_enable_auto_image_base=no ;;
 esac
 fi
-rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext
+rm -f core conftest.err conftest.$ac_objext conftest.beam \
+    conftest$ac_exeext conftest.$ac_ext
      ;;
 esac
 fi
diff --git a/win/tcl.m4 b/win/tcl.m4
index 8e55d70..2ab48fc 100644
--- a/win/tcl.m4
+++ b/win/tcl.m4
@@ -579,7 +579,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
 
     if test "${GCC}" = "yes" ; then
 	extra_cflags="-pipe"
-	extra_ldflags="-pipe -static-libgcc -Wl,--disable-high-entropy-va"
+	extra_ldflags="-pipe -static-libgcc"
 	AC_CACHE_CHECK(for mingw32 version of gcc,
 	    ac_cv_win32,
 	    AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
@@ -626,6 +626,16 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
 	else
 	    CFLAGS_NOLTO=""
 	fi
+
+	AC_CACHE_CHECK([if the linker understands --disable-high-entropy-va],
+	    tcl_cv_ld_high_entropy, [
+	    hold_cflags=$CFLAGS; CFLAGS="$CFLAGS  -Wl,--disable-high-entropy-va"
+	    AC_LINK_IFELSE([AC_LANG_PROGRAM([[]], [[]])],[tcl_cv_ld_high_entropy=yes],[tcl_cv_ld_high_entropy=no])
+	    CFLAGS=$hold_cflags])
+	if test $tcl_cv_ld_high_entropy = yes; then
+	    extra_ldflags="$extra_ldflags -Wl,--disable-high-entropy-va"
+	fi
+
 	AC_CACHE_CHECK([if the compiler understands -finput-charset],
 	    tcl_cv_cc_input_charset, [
 	    hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -finput-charset=UTF-8"
@@ -639,7 +649,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
     hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Wl,--enable-auto-image-base"
     AC_CACHE_CHECK(for working --enable-auto-image-base,
 	ac_cv_enable_auto_image_base,
-    AC_COMPILE_IFELSE([AC_LANG_PROGRAM([])],
+    AC_LINK_IFELSE([AC_LANG_PROGRAM([])],
 	[ac_cv_enable_auto_image_base=yes],
 	[ac_cv_enable_auto_image_base=no])
     )
-- 
cgit v0.12


From 3a52401ad22fbde363f2edd92bbb815af21bb1a3 Mon Sep 17 00:00:00 2001
From: bch <brad.harder@gmail.com>
Date: Sun, 27 Jul 2025 17:42:04 +0000
Subject: comment grammar; NFC

---
 generic/tclNotify.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/generic/tclNotify.c b/generic/tclNotify.c
index 628beb7..d9d332e 100644
--- a/generic/tclNotify.c
+++ b/generic/tclNotify.c
@@ -390,7 +390,7 @@ Tcl_DeleteEventSource(
 void
 Tcl_QueueEvent(
     Tcl_Event *evPtr,		/* Event to add to queue. The storage space
-				 * must have been allocated the caller with
+				 * must have been allocated by the caller with
 				 * malloc (Tcl_Alloc), and it becomes the
 				 * property of the event queue. It will be
 				 * freed after the event has been handled. */
-- 
cgit v0.12


From d6ef48a7101ad3c603549af5f04bc1894293c6f0 Mon Sep 17 00:00:00 2001
From: apnadkarni <apnmbx-wits@yahoo.com>
Date: Wed, 30 Jul 2025 09:01:58 +0000
Subject: Update changes.md for TIP's 649 and 712

---
 changes.md | 5 +++++
 1 file changed, 5 insertions(+)

diff --git a/changes.md b/changes.md
index 9827520..2a30b68 100644
--- a/changes.md
+++ b/changes.md
@@ -10,11 +10,16 @@ Highlighted differences between Tcl 9.1 and Tcl 9.0 are summarized below,
 with focus on changes important to programmers using the Tcl library and
 writing Tcl scripts.
 
+# New commands and options
+
+- [New options -backslashes, -commands and -variables for subst command](https://core.tcl-lang.org/tips/doc/trunk/tip/712.md)
+
 # New public C API
 
 - [Tcl\_IsEmpty checks if the string representation of a value would be the empty string](https://core.tcl-lang.org/tips/doc/trunk/tip/711.md)
 - [Tcl\_GetEncodingNameForUser returns name of encoding from user settings](https://core.tcl-lang.org/tips/doc/trunk/tip/716.md)
 - [Tcl\_AttemptCreateHashEntry - version of Tcl\_CreateHashEntry that returns NULL instead of panic'ing on memory allocation errors](https://core.tcl-lang.org/tips/doc/trunk/tip/717.md)
+- [Tcl\_ListObjRange, Tcl\_ListObjRepeat, Tcl\_TclListObjReverse - C API for new list operations](https://core.tcl-lang.org/tips/doc/trunk/tip/649.md)
 
 # Performance
 
-- 
cgit v0.12


From 1ae6a7c4d3fabaad1094f21cd9bc4de87d768043 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 4 Aug 2025 08:58:57 +0000
Subject: The encoding fallback logic in ZIP handling can be done mostly by via
 Tcl_ExternalToUtfDStringEx now.

---
 generic/tclZipfs.c | 45 ++++++++++-----------------------------------
 1 file changed, 10 insertions(+), 35 deletions(-)

diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c
index de10c7f..ca71a34 100644
--- a/generic/tclZipfs.c
+++ b/generic/tclZipfs.c
@@ -961,9 +961,6 @@ DecodeZipEntryText(
     Tcl_DString *dstPtr)	/* Must have been initialized by caller! */
 {
     Tcl_Encoding encoding;
-    const char *src;
-    char *dst;
-    int dstLen, srcLen = inputLength, flags;
     Tcl_EncodingState state;
 
     if (inputLength < 1) {
@@ -971,41 +968,19 @@ DecodeZipEntryText(
     }
 
     /*
-     * We can't use Tcl_ExternalToUtfDString at this point; it has no way to
-     * fail. So we use this modified version of it that can report encoding
-     * errors to us (so we can fall back to something else).
+     * We Tcl_ExternalToUtfDStringEx because that can report if it failed,
+     * allowing us to try a different encoding.
      *
-     * The utf-8 encoding is implemented internally, and so is guaranteed to
-     * be present.
+     * The UTF-8 encoding is implemented internally, and so is guaranteed to
+     * be present. Tcl's own startup files (including the encoding definitions)
+     * should all have ASCII filenames, which is a subset of UTF-8, and so they
+     * should all work via this.
      */
 
-    src = (const char *) inputBytes;
-    dst = Tcl_DStringValue(dstPtr);
-    dstLen = dstPtr->spaceAvl - 1;
-    flags = TCL_ENCODING_START | TCL_ENCODING_END;	/* Special flag! */
-
-    while (1) {
-	int srcRead, dstWrote;
-	int result = Tcl_ExternalToUtf(NULL, tclUtf8Encoding, src, srcLen, flags,
-		&state, dst, dstLen, &srcRead, &dstWrote, NULL);
-	int soFar = dst + dstWrote - Tcl_DStringValue(dstPtr);
-
-	if (result == TCL_OK) {
-	    Tcl_DStringSetLength(dstPtr, soFar);
-	    return Tcl_DStringValue(dstPtr);
-	} else if (result != TCL_CONVERT_NOSPACE) {
-	    break;
-	}
-
-	flags &= ~TCL_ENCODING_START;
-	src += srcRead;
-	srcLen -= srcRead;
-	if (Tcl_DStringLength(dstPtr) == 0) {
-	    Tcl_DStringSetLength(dstPtr, dstLen);
-	}
-	Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1);
-	dst = Tcl_DStringValue(dstPtr) + soFar;
-	dstLen = Tcl_DStringLength(dstPtr) - soFar - 1;
+    if (Tcl_ExternalToUtfDStringEx(NULL, tclUtf8Encoding,
+	    (const char *) inputBytes, inputLength,
+	    TCL_ENCODING_PROFILE_STRICT, dstPtr, NULL) == TCL_OK) {
+	return Tcl_DStringValue(dstPtr);
     }
 
     /*
-- 
cgit v0.12


From 3cf7de3328410319e9d751dba8c09f8fa9f9be31 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 4 Aug 2025 13:32:52 +0000
Subject: unused variable warning

---
 generic/tclZipfs.c | 1 -
 1 file changed, 1 deletion(-)

diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c
index ca71a34..2ec0ec4 100644
--- a/generic/tclZipfs.c
+++ b/generic/tclZipfs.c
@@ -961,7 +961,6 @@ DecodeZipEntryText(
     Tcl_DString *dstPtr)	/* Must have been initialized by caller! */
 {
     Tcl_Encoding encoding;
-    Tcl_EncodingState state;
 
     if (inputLength < 1) {
 	return Tcl_DStringValue(dstPtr);
-- 
cgit v0.12


From 3858e79861fb749afe071091e7dc0530557ad24c Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 4 Aug 2025 16:03:04 +0000
Subject: Correction to semantics of jumpTableNum: value argument must fit in
 wide int, and non-integer is an error

---
 generic/tclExecute.c | 8 +++++---
 1 file changed, 5 insertions(+), 3 deletions(-)

diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 53c807b..1b675d5 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4661,10 +4661,13 @@ TEBCresume(
 	JumptableNumInfo *jtnPtr = (JumptableNumInfo *)
 		codePtr->auxDataArrayPtr[tblIdx].clientData;
 	TRACE(("%u \"%.20s\" => ", tblIdx, O2S(OBJ_AT_TOS)));
+	DECACHE_STACK_INFO();
 	Tcl_WideInt key;
-	if (Tcl_GetWideIntFromObj(NULL, OBJ_AT_TOS, &key) != TCL_OK) {
-	    goto jumpTableNumFallthrough;
+	if (Tcl_GetWideIntFromObj(interp, OBJ_AT_TOS, &key) != TCL_OK) {
+	    TRACE_ERROR(interp);
+	    goto gotError;
 	}
+	CACHE_STACK_INFO();
 	hPtr = Tcl_FindHashEntry(&jtnPtr->hashTable, INT2PTR(key));
 
     processJumpTableEntry:
@@ -4675,7 +4678,6 @@ TEBCresume(
 		    PC_REL + jumpOffset));
 	    NEXT_INST_F0(jumpOffset, 1);
 	}
-    jumpTableNumFallthrough:
 	TRACE_APPEND(("not found in table\n"));
 	NEXT_INST_F0(5, 1);
     }
-- 
cgit v0.12


From 609c82da5e03f038b47fef60b002a1bfb3134092 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 6 Aug 2025 09:30:14 +0000
Subject: Factor out a common pattern to aid comprehensibility

---
 generic/tclFCmd.c | 80 +++++++++++++++++++++++++------------------------------
 1 file changed, 37 insertions(+), 43 deletions(-)

diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index bfb5639..f305391 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -29,6 +29,34 @@ static int		FileForceOption(Tcl_Interp *interp,
 /*
  *---------------------------------------------------------------------------
  *
+ * CheckFilenameEncodable
+ *
+ *	This checks if a filename can be encoded on the target platform,
+ *	disallowing things like naked surrogates, etc.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	May update the interpreter result with an error message on failure.
+ *
+ *---------------------------------------------------------------------------
+ */
+static inline int
+CheckFilenameEncodable(
+    Tcl_Interp *interp,
+    Tcl_Obj *fileName)
+{
+    Tcl_DString ds;
+    int code = Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING,
+	    TclGetString(fileName), TCL_INDEX_NONE, 0, &ds, NULL);
+    Tcl_DStringFree(&ds);
+    return code == TCL_OK ? TCL_OK : TCL_ERROR;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
  * TclFileRenameCmd
  *
  *	This function implements the "rename" subcommand of the "file"
@@ -113,7 +141,6 @@ FileCopyRename(
     int i, result, force;
     Tcl_StatBuf statBuf;
     Tcl_Obj *target;
-    Tcl_DString ds;
 
     i = FileForceOption(interp, objc - 1, objv + 1, &force);
     if (i < 0) {
@@ -135,12 +162,9 @@ FileCopyRename(
     if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
 	return TCL_ERROR;
     }
-    if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(target),
-	    TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) {
-	Tcl_DStringFree(&ds);
+    if (CheckFilenameEncodable(interp, target) != TCL_OK) {
 	return TCL_ERROR;
     }
-    Tcl_DStringFree(&ds);
 
     result = TCL_OK;
 
@@ -232,7 +256,6 @@ TclFileMakeDirsCmd(
     Tcl_Obj *split = NULL;
     Tcl_Obj *target = NULL;
     Tcl_StatBuf statBuf;
-    Tcl_DString ds;
 
     result = TCL_OK;
     for (i = 1; i < objc; i++) {
@@ -240,13 +263,10 @@ TclFileMakeDirsCmd(
 	    result = TCL_ERROR;
 	    break;
 	}
-	if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(objv[i]),
-		TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) {
-	    Tcl_DStringFree(&ds);
+	if (CheckFilenameEncodable(interp, objv[i]) != TCL_OK) {
 	    result = TCL_ERROR;
 	    break;
 	}
-	Tcl_DStringFree(&ds);
 
 	split = Tcl_FSSplitPath(objv[i], &pobjc);
 	Tcl_IncrRefCount(split);
@@ -362,7 +382,6 @@ TclFileDeleteCmd(
     int i, force, result;
     Tcl_Obj *errfile;
     Tcl_Obj *errorBuffer = NULL;
-    Tcl_DString ds;
 
     i = FileForceOption(interp, objc - 1, objv + 1, &force);
     if (i < 0) {
@@ -380,13 +399,10 @@ TclFileDeleteCmd(
 	    result = TCL_ERROR;
 	    goto done;
 	}
-	if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(objv[i]),
-		TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) {
-	    Tcl_DStringFree(&ds);
+	if (CheckFilenameEncodable(interp, objv[i]) != TCL_OK) {
 	    result = TCL_ERROR;
 	    goto done;
 	}
-	Tcl_DStringFree(&ds);
 
 	/*
 	 * Call lstat() to get info so can delete symbolic link itself.
@@ -506,26 +522,19 @@ CopyRenameOneFile(
     Tcl_Obj *actualSource=NULL;	/* If source is a link, then this is the real
 				 * file/directory. */
     Tcl_StatBuf sourceStatBuf, targetStatBuf;
-    Tcl_DString ds;
 
     if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) {
 	return TCL_ERROR;
     }
-    if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(source),
-	    TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) {
-	Tcl_DStringFree(&ds);
+    if (CheckFilenameEncodable(interp, source) != TCL_OK) {
 	return TCL_ERROR;
     }
-    Tcl_DStringFree(&ds);
     if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
 	return TCL_ERROR;
     }
-    if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(target),
-	    TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) {
-	Tcl_DStringFree(&ds);
+    if (CheckFilenameEncodable(interp, target) != TCL_OK) {
 	return TCL_ERROR;
     }
-    Tcl_DStringFree(&ds);
 
     errfile = NULL;
     errorBuffer = NULL;
@@ -985,7 +994,6 @@ TclFileAttrsCmd(
     Tcl_Obj *objStrings = NULL;
     Tcl_Size numObjStrings = TCL_INDEX_NONE;
     Tcl_Obj *filePtr;
-    Tcl_DString ds;
 
     if (objc < 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "name ?-option value ...?");
@@ -996,12 +1004,9 @@ TclFileAttrsCmd(
     if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) {
 	return TCL_ERROR;
     }
-    if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(filePtr),
-	    TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) {
-	Tcl_DStringFree(&ds);
+    if (CheckFilenameEncodable(interp, filePtr) != TCL_OK) {
 	return TCL_ERROR;
     }
-    Tcl_DStringFree(&ds);
 
     objc -= 2;
     objv += 2;
@@ -1204,7 +1209,6 @@ TclFileLinkCmd(
 {
     Tcl_Obj *contents;
     int index;
-    Tcl_DString ds;
 
     if (objc < 2 || objc > 4) {
 	Tcl_WrongNumArgs(interp, 1, objv, "?-linktype? linkname ?target?");
@@ -1247,12 +1251,9 @@ TclFileLinkCmd(
 	if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(objv[index]),
-		TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) {
-	    Tcl_DStringFree(&ds);
+	if (CheckFilenameEncodable(interp, objv[index]) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	Tcl_DStringFree(&ds);
 
 	/*
 	 * Create link from source to target.
@@ -1310,12 +1311,9 @@ TclFileLinkCmd(
 	if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(objv[index]),
-		TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) {
-	    Tcl_DStringFree(&ds);
+	if (CheckFilenameEncodable(interp, objv[index]) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	Tcl_DStringFree(&ds);
 
 	/*
 	 * Read link
@@ -1367,7 +1365,6 @@ TclFileReadLinkCmd(
     Tcl_Obj *const objv[])
 {
     Tcl_Obj *contents;
-    Tcl_DString ds;
 
     if (objc != 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "name");
@@ -1377,12 +1374,9 @@ TclFileReadLinkCmd(
     if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
 	return TCL_ERROR;
     }
-    if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(objv[1]),
-	    TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) {
-	Tcl_DStringFree(&ds);
+    if (CheckFilenameEncodable(interp, objv[1]) != TCL_OK) {
 	return TCL_ERROR;
     }
-    Tcl_DStringFree(&ds);
 
     contents = Tcl_FSLink(objv[1], NULL, 0);
 
-- 
cgit v0.12


From 3095406395342d5fb5cc11bef3f79a335d2152c1 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 17 Aug 2025 21:22:29 +0000
Subject: Start making TclOO faster to initialise [effa2e2346]

---
 generic/tclOO.c       | 28 +++++++++++++++++++++++++
 generic/tclOOBasic.c  | 57 +++++++++++++++++++++++++++++++++++++++++++++++++++
 generic/tclOOInt.h    |  2 ++
 generic/tclOOScript.h |  8 --------
 tools/tclOOScript.tcl | 20 ------------------
 5 files changed, 87 insertions(+), 28 deletions(-)

diff --git a/generic/tclOO.c b/generic/tclOO.c
index 9db93a9..972e292 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -430,6 +430,10 @@ InitFoundation(
      * ensemble.
      */
 
+    CreateCmdInNS(interp, fPtr->helpersNs, "callback",
+	    TclOOCallbackObjCmd, NULL, NULL, 0);
+    CreateCmdInNS(interp, fPtr->helpersNs, "mymethod",
+	    TclOOCallbackObjCmd, NULL, NULL, 0);
     CreateCmdInNS(interp, fPtr->helpersNs, "next",
 	    NULL, TclOONextObjCmd, TclCompileObjectNextCmd, CMD_COMPILES_EXPANDED);
     CreateCmdInNS(interp, fPtr->helpersNs, "nextto",
@@ -3123,6 +3127,30 @@ Tcl_GetObjectName(
 /*
  * ----------------------------------------------------------------------
  *
+ * TclOOObjectMyName --
+ *
+ *	Utility function that returns the name of the object's [my], or NULL
+ *	if it has been deleted (or otherwise doesn't exist).
+ *
+ * ----------------------------------------------------------------------
+ */
+Tcl_Obj *
+TclOOObjectMyName(
+    Tcl_Interp *interp,
+    Object *oPtr)
+{
+    if (!oPtr->myCommand) {
+	return NULL;
+    }
+    Tcl_Obj *namePtr;
+    TclNewObj(namePtr);
+    Tcl_GetCommandFullName(interp, oPtr->myCommand, namePtr);
+    return namePtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * assorted trivial 'getter' functions
  *
  * ----------------------------------------------------------------------
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 2e9848d..aefa91d 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -1355,6 +1355,63 @@ TclOOCopyObjectCmd(
 }
 
 /*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOCallbackObjCmd --
+ *
+ *	Implementation of the [callback] command, which constructs callbacks
+ *	into the current object.
+ *
+ * ----------------------------------------------------------------------
+ */
+int
+TclOOCallbackObjCmd(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Interp *iPtr = (Interp *) interp;
+    CallFrame *framePtr = iPtr->varFramePtr;
+
+    /*
+     * Start with sanity checks on the calling context to make sure that we
+     * are invoked from a suitable method context. If so, we can safely
+     * retrieve the handle to the object call context.
+     */
+
+    if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"%s may only be called from inside a method",
+		TclGetString(objv[0])));
+	OO_ERROR(interp, CONTEXT_REQUIRED);
+	return TCL_ERROR;
+    }
+
+    CallContext *contextPtr = (CallContext *) framePtr->clientData;
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "method ...");
+	return TCL_ERROR;
+    }
+
+    // Get the [my] real name.
+    Tcl_Obj *namePtr = TclOOObjectMyName(interp, contextPtr->oPtr);
+    if (!namePtr) {
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		"no possible safe callback without my", TCL_AUTO_LENGTH));
+	OO_ERROR(interp, NO_MY);
+	return TCL_ERROR;
+    }
+
+    // No check that the method exists; could be dynamically added.
+
+    Tcl_Obj *listPtr = Tcl_NewListObj(1, &namePtr);
+    (void) TclListObjAppendElements(NULL, listPtr, objc-1, objv+1);
+    Tcl_SetObjResult(interp, listPtr);
+    return TCL_OK;
+}
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 913e6db..f7269c0 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -513,6 +513,7 @@ MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineObjSelfObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOODefinePrivateObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOODefinePropertyCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOUnknownDefinition;
+MODULE_SCOPE Tcl_ObjCmdProc	TclOOCallbackObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOCopyObjectCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOONextObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOONextToObjCmd;
@@ -609,6 +610,7 @@ MODULE_SCOPE int	TclNRObjectContextInvokeNext(Tcl_Interp *interp,
 MODULE_SCOPE void	TclOODefineBasicMethods(Class *clsPtr,
 			    const DeclaredClassMethod *dcm);
 MODULE_SCOPE Tcl_Obj *	TclOOObjectName(Tcl_Interp *interp, Object *oPtr);
+MODULE_SCOPE Tcl_Obj *	TclOOObjectMyName(Tcl_Interp *interp, Object *oPtr);
 MODULE_SCOPE void	TclOOReleaseClassContents(Tcl_Interp *interp,
 			    Object *oPtr);
 MODULE_SCOPE int	TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 98fa20e..50d827f 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -30,14 +30,6 @@ static const char *tclOOSetupScript =
 "\t::namespace path {}\n"
 "\tnamespace eval Helpers {\n"
 "\t\tnamespace path {}\n"
-"\t\tproc callback {method args} {\n"
-"\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n"
-"\t\t}\n"
-"\t\tnamespace export callback\n"
-"\t\tnamespace eval tmp {namespace import ::oo::Helpers::callback}\n"
-"\t\tnamespace export -clear\n"
-"\t\trename tmp::callback mymethod\n"
-"\t\tnamespace delete tmp\n"
 "\t\tproc classvariable {name args} {\n"
 "\t\t\tset ns [info object namespace [uplevel 1 {self class}]]\n"
 "\t\t\tforeach v [list $name {*}$args] {\n"
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 2110861..cb77bb3 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -22,26 +22,6 @@
 
 	# ------------------------------------------------------------------
 	#
-	# callback, mymethod --
-	#
-	#	Create a script prefix that calls a method on the current
-	#	object. Same operation, two names.
-	#
-	# ------------------------------------------------------------------
-
-	proc callback {method args} {
-	    list [uplevel 1 {::namespace which my}] $method {*}$args
-	}
-
-	# Make the [callback] command appear as [mymethod] too.
-	namespace export callback
-	namespace eval tmp {namespace import ::oo::Helpers::callback}
-	namespace export -clear
-	rename tmp::callback mymethod
-	namespace delete tmp
-
-	# ------------------------------------------------------------------
-	#
 	# classvariable --
 	#
 	#	Link to a variable in the class of the current object.
-- 
cgit v0.12


From 67c8c510019783025abc5ab4e73df47631b61676 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 18 Aug 2025 08:56:11 +0000
Subject: Accelerate definition of [oo::define initialise]. [effa2e2346]

---
 generic/tclOO.c           |  2 ++
 generic/tclOODefineCmds.c | 47 +++++++++++++++++++++++++++++++++++++++++++++++
 generic/tclOOInt.h        |  1 +
 generic/tclOOScript.h     | 11 -----------
 tests/ooUtil.test         | 10 ++--------
 tools/tclOOScript.tcl     | 26 --------------------------
 6 files changed, 52 insertions(+), 45 deletions(-)

diff --git a/generic/tclOO.c b/generic/tclOO.c
index 972e292..e1dd40f 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 edccec3..5ca69e2 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)
+{
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "body");
+	return TCL_ERROR;
+    }
+
+    // Build the lambda
+    Tcl_Object object = TclOOGetDefineCmdContext(interp);
+    if (object == NULL) {
+	return TCL_ERROR;
+    }
+    Tcl_Obj *lambdaWords[] = {
+	Tcl_NewObj(),
+	objv[1],
+	TclNewNamespaceObj(Tcl_GetObjectNamespace(object))
+    };
+
+    // Delegate to [apply] to run it
+    Tcl_Obj *applyArgs[] = {
+	Tcl_NewStringObj("apply", -1),
+	Tcl_NewListObj(3, lambdaWords)
+    };
+    Tcl_IncrRefCount(applyArgs[0]);
+    Tcl_IncrRefCount(applyArgs[1]);
+    int 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 f7269c0..e4351f6 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 ec0fbe3..74ffa8e 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
-- 
cgit v0.12


From 111470b8a20de3788ec89fdb1c87c85fd45bfed1 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 18 Aug 2025 11:39:40 +0000
Subject: Slightly chisel down the execution time of the oo init script,

---
 generic/tclOOScript.h |  97 +++++++++++++--------------
 tools/tclOOScript.tcl | 179 ++++++++++++++++++++++++--------------------------
 2 files changed, 131 insertions(+), 145 deletions(-)

diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index ff29535..7b8a69d 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -27,46 +27,41 @@
 static const char *tclOOSetupScript =
 /* !BEGIN!: Do not edit below this line. */
 "::namespace eval ::oo {\n"
-"\t::namespace path {}\n"
-"\tnamespace eval Helpers {\n"
-"\t\tnamespace path {}\n"
-"\t\tproc classvariable {name args} {\n"
-"\t\t\tset ns [info object namespace [uplevel 1 {self class}]]\n"
-"\t\t\tforeach v [list $name {*}$args] {\n"
-"\t\t\t\tif {[string match *(*) $v]} {\n"
-"\t\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n"
-"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n"
-"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
-"\t\t\t\t}\n"
-"\t\t\t\tif {[string match *::* $v]} {\n"
-"\t\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n"
-"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n"
-"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
-"\t\t\t\t}\n"
-"\t\t\t\tlappend vs $v $v\n"
+"\tproc Helpers::classvariable {name args} {\n"
+"\t\tset ns [info object namespace [uplevel 1 {self class}]]\n"
+"\t\tforeach v [list $name {*}$args] {\n"
+"\t\t\tif {[string match *(*) $v]} {\n"
+"\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n"
+"\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n"
+"\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
 "\t\t\t}\n"
-"\t\t\ttailcall namespace upvar $ns {*}$vs\n"
+"\t\t\tif {[string match *::* $v]} {\n"
+"\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n"
+"\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n"
+"\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
+"\t\t\t}\n"
+"\t\t\tlappend vs $v $v\n"
 "\t\t}\n"
-"\t\tproc link {args} {\n"
-"\t\t\tset ns [uplevel 1 {::namespace current}]\n"
-"\t\t\tforeach link $args {\n"
-"\t\t\t\tif {[llength $link] == 2} {\n"
-"\t\t\t\t\tlassign $link src dst\n"
-"\t\t\t\t} elseif {[llength $link] == 1} {\n"
-"\t\t\t\t\tlassign $link src\n"
-"\t\t\t\t\tset dst $src\n"
-"\t\t\t\t} else {\n"
-"\t\t\t\t\treturn -code error -errorcode {TCL OO CMDLINK_FORMAT} \\\n"
-"\t\t\t\t\t\t\"bad link description; must only have one or two elements\"\n"
-"\t\t\t\t}\n"
-"\t\t\t\tif {![string match ::* $src]} {\n"
-"\t\t\t\t\tset src [string cat $ns :: $src]\n"
-"\t\t\t\t}\n"
-"\t\t\t\tinterp alias {} $src {} ${ns}::my $dst\n"
-"\t\t\t\ttrace add command ${ns}::my delete [list \\\n"
-"\t\t\t\t\t::oo::UnlinkLinkedCommand $src]\n"
+"\t\ttailcall namespace upvar $ns {*}$vs\n"
+"\t}\n"
+"\tproc Helpers::link {args} {\n"
+"\t\tset ns [uplevel 1 {::namespace current}]\n"
+"\t\tforeach link $args {\n"
+"\t\t\tif {[llength $link] == 2} {\n"
+"\t\t\t\tlassign $link src dst\n"
+"\t\t\t} elseif {[llength $link] == 1} {\n"
+"\t\t\t\tlassign $link src\n"
+"\t\t\t\tset dst $src\n"
+"\t\t\t} else {\n"
+"\t\t\t\treturn -code error -errorcode {TCL OO CMDLINK_FORMAT} \\\n"
+"\t\t\t\t\t\"bad link description; must only have one or two elements\"\n"
 "\t\t\t}\n"
-"\t\t\treturn\n"
+"\t\t\tif {![string match ::* $src]} {\n"
+"\t\t\t\tset src [string cat $ns :: $src]\n"
+"\t\t\t}\n"
+"\t\t\tinterp alias {} $src {} ${ns}::my $dst\n"
+"\t\t\ttrace add command ${ns}::my delete [list \\\n"
+"\t\t\t\t::oo::UnlinkLinkedCommand $src]\n"
 "\t\t}\n"
 "\t}\n"
 "\tproc UnlinkLinkedCommand {cmd args} {\n"
@@ -239,21 +234,19 @@ static const char *tclOOSetupScript =
 "\t\tsuperclass class\n"
 "\t\tunexport create createWithNamespace new\n"
 "\t}\n"
-"\tnamespace eval configuresupport {\n"
-"\t\t::namespace eval configurableclass {\n"
-"\t\t\t::proc properties args {::tailcall property {*}$args}\n"
-"\t\t\t::namespace path ::oo::define\n"
-"\t\t\t::namespace export property\n"
-"\t\t}\n"
-"\t\t::namespace eval configurableobject {\n"
-"\t\t\t::proc properties args {::tailcall property {*}$args}\n"
-"\t\t\t::namespace path ::oo::objdefine\n"
-"\t\t\t::namespace export property\n"
-"\t\t}\n"
-"\t\t::oo::define configurable {\n"
-"\t\t\tdefinitionnamespace -instance configurableobject\n"
-"\t\t\tdefinitionnamespace -class configurableclass\n"
-"\t\t}\n"
+"\tnamespace eval configuresupport::configurableclass {\n"
+"\t\t::proc properties args {::tailcall property {*}$args}\n"
+"\t\t::namespace path ::oo::define\n"
+"\t\t::namespace export property\n"
+"\t}\n"
+"\tnamespace eval configuresupport::configurableobject {\n"
+"\t\t::proc properties args {::tailcall property {*}$args}\n"
+"\t\t::namespace path ::oo::objdefine\n"
+"\t\t::namespace export property\n"
+"\t}\n"
+"\tdefine configuresupport::configurable {\n"
+"\t\tdefinitionnamespace -instance configuresupport::configurableobject\n"
+"\t\tdefinitionnamespace -class configuresupport::configurableclass\n"
 "\t}\n"
 "\tclass create configurable {\n"
 "\t\tsuperclass class\n"
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index b60542f..442756d 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -12,73 +12,68 @@
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
 ::namespace eval ::oo {
-    ::namespace path {}
 
     #
     # Commands that are made available to objects by default.
     #
-    namespace eval Helpers {
-	namespace path {}
 
-	# ------------------------------------------------------------------
-	#
-	# classvariable --
-	#
-	#	Link to a variable in the class of the current object.
-	#
-	# ------------------------------------------------------------------
+    # ------------------------------------------------------------------
+    #
+    # classvariable --
+    #
+    #	Link to a variable in the class of the current object.
+    #
+    # ------------------------------------------------------------------
 
-	proc classvariable {name args} {
-	    # Get a reference to the class's namespace
-	    set ns [info object namespace [uplevel 1 {self class}]]
-	    # Double up the list of variable names
-	    foreach v [list $name {*}$args] {
-		if {[string match *(*) $v]} {
-		    set reason "can't create a scalar variable that looks like an array element"
-		    return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \
-			[format {bad variable name "%s": %s} $v $reason]
-		}
-		if {[string match *::* $v]} {
-		    set reason "can't create a local variable with a namespace separator in it"
-		    return -code error -errorcode {TCL UPVAR INVERTED} \
-			[format {bad variable name "%s": %s} $v $reason]
-		}
-		lappend vs $v $v
+    proc Helpers::classvariable {name args} {
+	# Get a reference to the class's namespace
+	set ns [info object namespace [uplevel 1 {self class}]]
+	# Double up the list of variable names
+	foreach v [list $name {*}$args] {
+	    if {[string match *(*) $v]} {
+		set reason "can't create a scalar variable that looks like an array element"
+		return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \
+		    [format {bad variable name "%s": %s} $v $reason]
+	    }
+	    if {[string match *::* $v]} {
+		set reason "can't create a local variable with a namespace separator in it"
+		return -code error -errorcode {TCL UPVAR INVERTED} \
+		    [format {bad variable name "%s": %s} $v $reason]
 	    }
-	    # Lastly, link the caller's local variables to the class's variables
-	    tailcall namespace upvar $ns {*}$vs
+	    lappend vs $v $v
 	}
+	# Lastly, link the caller's local variables to the class's variables
+	tailcall namespace upvar $ns {*}$vs
+    }
 
-	# ------------------------------------------------------------------
-	#
-	# link --
-	#
-	#	Make a command that invokes a method on the current object.
-	#	The name of the command and the name of the method match by
-	#	default.
-	#
-	# ------------------------------------------------------------------
+    # ------------------------------------------------------------------
+    #
+    # link --
+    #
+    #	Make a command that invokes a method on the current object.
+    #	The name of the command and the name of the method match by
+    #	default.
+    #
+    # ------------------------------------------------------------------
 
-	proc link {args} {
-	    set ns [uplevel 1 {::namespace current}]
-	    foreach link $args {
-		if {[llength $link] == 2} {
-		    lassign $link src dst
-		} elseif {[llength $link] == 1} {
-		    lassign $link src
-		    set dst $src
-		} else {
-		    return -code error -errorcode {TCL OO CMDLINK_FORMAT} \
-			"bad link description; must only have one or two elements"
-		}
-		if {![string match ::* $src]} {
-		    set src [string cat $ns :: $src]
-		}
-		interp alias {} $src {} ${ns}::my $dst
-		trace add command ${ns}::my delete [list \
-		    ::oo::UnlinkLinkedCommand $src]
+    proc Helpers::link {args} {
+	set ns [uplevel 1 {::namespace current}]
+	foreach link $args {
+	    if {[llength $link] == 2} {
+		lassign $link src dst
+	    } elseif {[llength $link] == 1} {
+		lassign $link src
+		set dst $src
+	    } else {
+		return -code error -errorcode {TCL OO CMDLINK_FORMAT} \
+		    "bad link description; must only have one or two elements"
 	    }
-	    return
+	    if {![string match ::* $src]} {
+		set src [string cat $ns :: $src]
+	    }
+	    interp alias {} $src {} ${ns}::my $dst
+	    trace add command ${ns}::my delete [list \
+		::oo::UnlinkLinkedCommand $src]
 	}
     }
 
@@ -437,47 +432,45 @@
     #
     # ----------------------------------------------------------------------
 
-    namespace eval configuresupport {
-	# ------------------------------------------------------------------
-	#
-	# oo::configuresupport::configurableclass,
-	# oo::configuresupport::configurableobject --
-	#
-	#	Namespaces used as implementation vectors for oo::define and
-	#	oo::objdefine when the class/instance is configurable.
-	#	Note that these also contain commands implemented in C,
-	#	especially the [property] definition command.
-	#
-	# ------------------------------------------------------------------
+    # ------------------------------------------------------------------
+    #
+    # oo::configuresupport::configurableclass,
+    # oo::configuresupport::configurableobject --
+    #
+    #	Namespaces used as implementation vectors for oo::define and
+    #	oo::objdefine when the class/instance is configurable.
+    #	Note that these also contain commands implemented in C,
+    #	especially the [property] definition command.
+    #
+    # ------------------------------------------------------------------
 
-	::namespace eval configurableclass {
-	    # Plural alias just in case; deliberately NOT documented!
-	    ::proc properties args {::tailcall property {*}$args}
-	    ::namespace path ::oo::define
-	    ::namespace export property
-	}
+    namespace eval configuresupport::configurableclass {
+	# Plural alias just in case; deliberately NOT documented!
+	::proc properties args {::tailcall property {*}$args}
+	::namespace path ::oo::define
+	::namespace export property
+    }
 
-	::namespace eval configurableobject {
-	    # Plural alias just in case; deliberately NOT documented!
-	    ::proc properties args {::tailcall property {*}$args}
-	    ::namespace path ::oo::objdefine
-	    ::namespace export property
-	}
+    namespace eval configuresupport::configurableobject {
+	# Plural alias just in case; deliberately NOT documented!
+	::proc properties args {::tailcall property {*}$args}
+	::namespace path ::oo::objdefine
+	::namespace export property
+    }
 
-	# ------------------------------------------------------------------
-	#
-	# oo::configuresupport::configurable --
-	#
-	#	The class that contains the implementation of the actual
-	#	'configure' method (mixed into actually configurable classes).
-	#	The 'configure' method is in tclOOBasic.c.
-	#
-	# ------------------------------------------------------------------
+    # ------------------------------------------------------------------
+    #
+    # oo::configuresupport::configurable --
+    #
+    #	The class that contains the implementation of the actual
+    #	'configure' method (mixed into actually configurable classes).
+    #	The 'configure' method is in tclOOBasic.c.
+    #
+    # ------------------------------------------------------------------
 
-	::oo::define configurable {
-	    definitionnamespace -instance configurableobject
-	    definitionnamespace -class configurableclass
-	}
+    define configuresupport::configurable {
+	definitionnamespace -instance configuresupport::configurableobject
+	definitionnamespace -class configuresupport::configurableclass
     }
 
     # ----------------------------------------------------------------------
-- 
cgit v0.12


From 4a3783d6dfd19edde7bac018d19ccdb351a8bca9 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 19 Aug 2025 08:57:06 +0000
Subject: Working on rewriting the slot implementation in C; not quite correct
 yet

---
 generic/tclOODefineCmds.c | 373 ++++++++++++++++++++++++++++++++++++++++++++--
 generic/tclOOScript.h     |  35 +----
 tools/tclOOScript.tcl     |  67 +--------
 3 files changed, 366 insertions(+), 109 deletions(-)

diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 5ca69e2..0395599 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -39,15 +39,25 @@ typedef struct DeclaredSlot {
     const Tcl_MethodType resolverType;
 } DeclaredSlot;
 
-#define SLOT(name,getter,setter,resolver)				\
+#define SLOT(name,getter,setter,resolver) \
     {"::oo::" name,							\
-	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \
+	    {TCL_OO_METHOD_VERSION_1, "core method: " name " Getter",	\
 		    getter, NULL, NULL},				\
-	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \
+	    {TCL_OO_METHOD_VERSION_1, "core method: " name " Setter",	\
 		    setter, NULL, NULL},				\
-	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \
+	    {TCL_OO_METHOD_VERSION_1, "core method: " name " Resolver",	\
 		    resolver, NULL, NULL}}
 
+typedef struct DeclaredSlotMethod {
+    const char *name;
+    int flags;
+    const Tcl_MethodType implType;
+} DeclaredSlotMethod;
+
+#define SLOT_METHOD(name,impl,flags) \
+    {name, flags, {TCL_OO_METHOD_VERSION_1,				\
+	    "core method: " name " slot", impl, NULL, NULL}}
+
 /*
  * A [string match] pattern used to determine if a method should be exported.
  */
@@ -78,6 +88,39 @@ static inline void	RecomputeClassCacheFlag(Object *oPtr);
 static int		RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
 			    int useClass, Tcl_Obj *const fromPtr,
 			    Tcl_Obj *const toPtr);
+static int		Slot_Append(void *clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+#if 0 // TODO
+static int		Slot_AppendNew(void *clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+#endif
+static int		Slot_Clear(void *clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		Slot_Prepend(void *clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+#if 0 // TODO
+static int		Slot_Remove(void *clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+#endif
+static int		Slot_Resolve(void *clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		Slot_Set(void *clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		Slot_Unimplemented(void *clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+#if 0 // TODO
+static int		Slot_Unknown(void *clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+#endif
 static int		ClassFilter_Get(void *clientData,
 			    Tcl_Interp *interp, Tcl_ObjectContext context,
 			    int objc, Tcl_Obj *const *objv);
@@ -175,6 +218,22 @@ static const DeclaredSlot slots[] = {
     {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
 };
 
+static const DeclaredSlotMethod slotMethods[] = {
+    SLOT_METHOD("Get",		Slot_Unimplemented, 0),
+    SLOT_METHOD("Resolve",	Slot_Resolve,	0),
+    SLOT_METHOD("Set",		Slot_Unimplemented, 0),
+    SLOT_METHOD("-append",	Slot_Append,	PUBLIC_METHOD),
+    SLOT_METHOD("-clear",	Slot_Clear,	PUBLIC_METHOD),
+    SLOT_METHOD("-prepend",	Slot_Prepend,	PUBLIC_METHOD),
+    SLOT_METHOD("-set",		Slot_Set,	PUBLIC_METHOD),
+#if 0 // TODO
+    SLOT_METHOD("-appendifnew",	Slot_AppendNew,	PUBLIC_METHOD),
+    SLOT_METHOD("-remove",	Slot_Remove,	PUBLIC_METHOD),
+    SLOT_METHOD("unknown",	Slot_Unknown,	0),
+#endif
+    {NULL, 0, {0, 0, 0, 0, 0}}
+};
+
 /*
  * How to build the in-namespace name of a private variable. This is a pattern
  * used with Tcl_ObjPrintf().
@@ -2397,39 +2456,43 @@ int
 TclOODefineSlots(
     Foundation *fPtr)
 {
-    const DeclaredSlot *slotInfoPtr;
     Tcl_Interp *interp = fPtr->interp;
-    Tcl_Obj *getName, *setName, *resolveName;
     Tcl_Object object = Tcl_NewObjectInstance(interp, (Tcl_Class)
 	    fPtr->classCls, "::oo::Slot", NULL, TCL_INDEX_NONE, NULL, 0);
-    Class *slotCls;
 
     if (object == NULL) {
 	return TCL_ERROR;
     }
-    slotCls = ((Object *) object)->classPtr;
+    Tcl_Class slotCls = (Tcl_Class) ((Object *) object)->classPtr;
     if (slotCls == NULL) {
 	return TCL_ERROR;
     }
 
+    for (const DeclaredSlotMethod *smPtr = slotMethods; smPtr->name; smPtr++) {
+	Tcl_Obj *name = Tcl_NewStringObj(smPtr->name, -1);
+	Tcl_NewMethod(interp, slotCls, name, smPtr->flags,
+		&smPtr->implType, NULL);
+	Tcl_BounceRefCount(name);
+    }
+
+    Tcl_Obj *getName, *setName, *resolveName;
     TclNewLiteralStringObj(getName, "Get");
     TclNewLiteralStringObj(setName, "Set");
     TclNewLiteralStringObj(resolveName, "Resolve");
-    for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) {
+    for (const DeclaredSlot *slotPtr = slots ; slotPtr->name ; slotPtr++) {
 	Tcl_Object slotObject = Tcl_NewObjectInstance(interp,
-		(Tcl_Class) slotCls, slotInfoPtr->name, NULL, TCL_INDEX_NONE,
-		NULL, 0);
+		slotCls, slotPtr->name, NULL, TCL_INDEX_NONE, NULL, 0);
 
 	if (slotObject == NULL) {
 	    continue;
 	}
 	TclNewInstanceMethod(interp, slotObject, getName, 0,
-		&slotInfoPtr->getterType, NULL);
+		&slotPtr->getterType, NULL);
 	TclNewInstanceMethod(interp, slotObject, setName, 0,
-		&slotInfoPtr->setterType, NULL);
-	if (slotInfoPtr->resolverType.callProc) {
+		&slotPtr->setterType, NULL);
+	if (slotPtr->resolverType.callProc) {
 	    TclNewInstanceMethod(interp, slotObject, resolveName, 0,
-		    &slotInfoPtr->resolverType, NULL);
+		    &slotPtr->resolverType, NULL);
 	}
     }
     Tcl_BounceRefCount(getName);
@@ -2438,6 +2501,286 @@ TclOODefineSlots(
     return TCL_OK;
 }
 
+static int
+Slot_Append(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+    if (Tcl_ObjectContextSkippedArgs(context) == objc) {
+	return TCL_OK;
+    }
+    objc -= Tcl_ObjectContextSkippedArgs(context);
+    objv += Tcl_ObjectContextSkippedArgs(context);
+
+    Tcl_Obj *args[3];
+    args[0] = Tcl_NewStringObj("my", -1);
+    Tcl_IncrRefCount(args[0]);
+
+    // Resolve all values
+    Tcl_Obj **resolved = (Tcl_Obj **)
+	    TclStackAlloc(interp, sizeof(Tcl_Obj *) * objc);
+    args[1] = Tcl_NewStringObj("Resolve", -1);
+    Tcl_IncrRefCount(args[1]);
+    for (int i = 0; i < objc; i++) {
+	args[2] = objv[i];
+	if (TclOOPrivateObjectCmd(oPtr, interp, 3, args) != TCL_OK) {
+	    Tcl_DecrRefCount(args[0]);
+	    Tcl_DecrRefCount(args[1]);
+	    for (int j = 0; j < i; j++) {
+		Tcl_DecrRefCount(resolved[j]);
+	    }
+	    TclStackFree(interp, (void *) resolved);
+	    return TCL_ERROR;
+	}
+	resolved[i] = Tcl_GetObjResult(interp);
+	Tcl_IncrRefCount(resolved[i]);
+	Tcl_ResetResult(interp);
+    }
+    Tcl_DecrRefCount(args[1]);
+
+    // Get slot contents; store in args[2]
+    args[1] = Tcl_NewStringObj("Get", -1);
+    Tcl_IncrRefCount(args[1]);
+    if (TclOOPrivateObjectCmd(oPtr, interp, 2, args) != TCL_OK) {
+	Tcl_DecrRefCount(args[0]);
+	Tcl_DecrRefCount(args[1]);
+	for (int j = 0; j < objc; j++) {
+	    Tcl_DecrRefCount(resolved[j]);
+	}
+	TclStackFree(interp, (void *) resolved);
+	return TCL_ERROR;
+    }
+    args[2] = Tcl_GetObjResult(interp);
+    Tcl_IncrRefCount(args[2]);
+    Tcl_DecrRefCount(args[1]);
+    Tcl_ResetResult(interp);
+
+    // Append
+    if (Tcl_IsShared(args[2])) {
+	Tcl_Obj *dup = Tcl_DuplicateObj(args[2]);
+	Tcl_IncrRefCount(dup);
+	Tcl_DecrRefCount(args[2]);
+	args[2] = dup;
+    }
+    if (TclListObjAppendElements(interp, args[2], objc, resolved) != TCL_OK) {
+	Tcl_DecrRefCount(args[0]);
+	Tcl_DecrRefCount(args[2]);
+	for (int j = 0; j < objc; j++) {
+	    Tcl_DecrRefCount(resolved[j]);
+	}
+	TclStackFree(interp, (void *) resolved);
+	return TCL_ERROR;
+    }
+    for (int j = 0; j < objc; j++) {
+	Tcl_DecrRefCount(resolved[j]);
+    }
+    TclStackFree(interp, (void *) resolved);
+    // resolved is now non-referenceable
+
+    // Set slot contents
+    args[1] = Tcl_NewStringObj("Set", -1);
+    Tcl_IncrRefCount(args[1]);
+    int code = TclOOPrivateObjectCmd(oPtr, interp, 3, args);
+    Tcl_DecrRefCount(args[0]);
+    Tcl_IncrRefCount(args[1]);
+    Tcl_IncrRefCount(args[2]);
+    return code;
+}
+
+static int
+Slot_Clear(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		NULL);
+	return TCL_ERROR;
+    }
+    Tcl_Obj *args[] = {
+	Tcl_NewStringObj("my", -1),
+	Tcl_NewStringObj("Set", -1),
+	Tcl_NewObj()
+    };
+    Tcl_IncrRefCount(args[0]);
+    Tcl_IncrRefCount(args[1]);
+    Tcl_IncrRefCount(args[2]);
+    int code = TclOOPrivateObjectCmd(oPtr, interp, 3, args);
+    Tcl_DecrRefCount(args[0]);
+    Tcl_IncrRefCount(args[1]);
+    Tcl_IncrRefCount(args[2]);
+    return code;
+}
+
+static int
+Slot_Prepend(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+    if (Tcl_ObjectContextSkippedArgs(context) == objc) {
+	return TCL_OK;
+    }
+    objc -= Tcl_ObjectContextSkippedArgs(context);
+    objv += Tcl_ObjectContextSkippedArgs(context);
+
+    Tcl_Obj *args[3];
+    args[0] = Tcl_NewStringObj("my", -1);
+    Tcl_IncrRefCount(args[0]);
+
+    // Resolve all values
+    Tcl_Obj **resolved = (Tcl_Obj **)
+	    TclStackAlloc(interp, sizeof(Tcl_Obj *) * objc);
+    args[1] = Tcl_NewStringObj("Resolve", -1);
+    Tcl_IncrRefCount(args[1]);
+    for (int i = 0; i < objc; i++) {
+	args[2] = objv[i];
+	if (TclOOPrivateObjectCmd(oPtr, interp, 3, args) != TCL_OK) {
+	    Tcl_DecrRefCount(args[0]);
+	    Tcl_DecrRefCount(args[1]);
+	    for (int j = 0; j < i; j++) {
+		Tcl_DecrRefCount(resolved[j]);
+	    }
+	    TclStackFree(interp, (void *) resolved);
+	    return TCL_ERROR;
+	}
+	resolved[i] = Tcl_GetObjResult(interp);
+	Tcl_IncrRefCount(resolved[i]);
+	Tcl_ResetResult(interp);
+    }
+    Tcl_DecrRefCount(args[1]);
+    Tcl_Obj *list = Tcl_NewListObj(objc, resolved);
+    Tcl_IncrRefCount(list);
+    for (int j = 0; j < objc; j++) {
+	Tcl_DecrRefCount(resolved[j]);
+    }
+    TclStackFree(interp, (void *) resolved);
+    // resolved is now non-referenceable
+
+    // Get slot contents and append to list
+    args[1] = Tcl_NewStringObj("Get", -1);
+    Tcl_IncrRefCount(args[1]);
+    if (TclOOPrivateObjectCmd(oPtr, interp, 2, args) != TCL_OK) {
+	Tcl_DecrRefCount(args[0]);
+	Tcl_DecrRefCount(args[1]);
+	Tcl_DecrRefCount(list);
+	return TCL_ERROR;
+    }
+    Tcl_ListObjAppendList(NULL, list, Tcl_GetObjResult(interp));
+    Tcl_ResetResult(interp);
+
+    // Set slot contents
+    args[1] = Tcl_NewStringObj("Set", -1);
+    args[2] = list; // Already has a ref
+    Tcl_IncrRefCount(args[1]);
+    int code = TclOOPrivateObjectCmd(oPtr, interp, 3, args);
+    Tcl_DecrRefCount(args[0]);
+    Tcl_IncrRefCount(args[1]);
+    Tcl_IncrRefCount(args[2]);
+    return code;
+}
+
+static int
+Slot_Resolve(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		"list");
+	return TCL_ERROR;
+    }
+    Tcl_SetObjResult(interp, objv[objc - 1]);
+    return TCL_OK;
+}
+
+static int
+Slot_Set(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+    if (Tcl_ObjectContextSkippedArgs(context) == objc) {
+	return TCL_OK;
+    }
+    objc -= Tcl_ObjectContextSkippedArgs(context);
+    objv += Tcl_ObjectContextSkippedArgs(context);
+
+    Tcl_Obj *args[3];
+    args[0] = Tcl_NewStringObj("my", -1);
+    Tcl_IncrRefCount(args[0]);
+
+    // Resolve all values
+    Tcl_Obj **resolved = (Tcl_Obj **)
+	    TclStackAlloc(interp, sizeof(Tcl_Obj *) * objc);
+    args[1] = Tcl_NewStringObj("Resolve", -1);
+    Tcl_IncrRefCount(args[1]);
+    for (int i = 0; i < objc; i++) {
+	args[2] = objv[i];
+	if (TclOOPrivateObjectCmd(oPtr, interp, 3, args) != TCL_OK) {
+	    Tcl_DecrRefCount(args[0]);
+	    Tcl_DecrRefCount(args[1]);
+	    for (int j = 0; j < i; j++) {
+		Tcl_DecrRefCount(resolved[j]);
+	    }
+	    TclStackFree(interp, (void *) resolved);
+	    return TCL_ERROR;
+	}
+	resolved[i] = Tcl_GetObjResult(interp);
+	Tcl_IncrRefCount(resolved[i]);
+	Tcl_ResetResult(interp);
+    }
+    Tcl_DecrRefCount(args[1]);
+
+    // Make a list
+    args[2] = Tcl_NewListObj(objc, resolved);
+    Tcl_IncrRefCount(args[2]);
+    for (int j = 0; j < objc; j++) {
+	Tcl_DecrRefCount(resolved[j]);
+    }
+    TclStackFree(interp, (void *) resolved);
+    // resolved is now non-referenceable
+
+    // Set slot contents
+    args[1] = Tcl_NewStringObj("Set", -1);
+    Tcl_IncrRefCount(args[1]);
+    int code = TclOOPrivateObjectCmd(oPtr, interp, 3, args);
+    Tcl_DecrRefCount(args[0]);
+    Tcl_IncrRefCount(args[1]);
+    Tcl_IncrRefCount(args[2]);
+    return code;
+}
+
+static int
+Slot_Unimplemented(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    TCL_UNUSED(Tcl_ObjectContext),
+    TCL_UNUSED(int),
+    TCL_UNUSED(Tcl_Obj *const *))
+{
+    Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
+    OO_ERROR(interp, ABSTRACT_SLOT);
+    return TCL_ERROR;
+}
+
 /*
  * ----------------------------------------------------------------------
  *
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 7b8a69d..796a5cf 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -117,26 +117,6 @@ static const char *tclOOSetupScript =
 "\t\t::tailcall forward $name myclass $name\n"
 "\t}\n"
 "\tdefine Slot {\n"
-"\t\tmethod Get -unexport {} {\n"
-"\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n"
-"\t\t}\n"
-"\t\tmethod Set -unexport list {\n"
-"\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n"
-"\t\t}\n"
-"\t\tmethod Resolve -unexport list {\n"
-"\t\t\treturn $list\n"
-"\t\t}\n"
-"\t\tmethod -set -export args {\n"
-"\t\t\tset my [namespace which my]\n"
-"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
-"\t\t\ttailcall my Set $args\n"
-"\t\t}\n"
-"\t\tmethod -append -export args {\n"
-"\t\t\tset my [namespace which my]\n"
-"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
-"\t\t\tset current [uplevel 1 [list $my Get]]\n"
-"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
-"\t\t}\n"
 "\t\tmethod -appendifnew -export args {\n"
 "\t\t\tset my [namespace which my]\n"
 "\t\t\tset current [uplevel 1 [list $my Get]]\n"
@@ -148,13 +128,6 @@ static const char *tclOOSetupScript =
 "\t\t\t}\n"
 "\t\t\ttailcall my Set $current\n"
 "\t\t}\n"
-"\t\tmethod -clear -export {} {tailcall my Set {}}\n"
-"\t\tmethod -prepend -export args {\n"
-"\t\t\tset my [namespace which my]\n"
-"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
-"\t\t\tset current [uplevel 1 [list $my Get]]\n"
-"\t\t\ttailcall my Set [list {*}$args {*}$current]\n"
-"\t\t}\n"
 "\t\tmethod -remove -export args {\n"
 "\t\t\tset my [namespace which my]\n"
 "\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
@@ -210,8 +183,8 @@ static const char *tclOOSetupScript =
 "\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
 "\t}\n"
 "\tclass create singleton {\n"
-"\t\tsuperclass class\n"
-"\t\tvariable object\n"
+"\t\tsuperclass -set class\n"
+"\t\tvariable -set object\n"
 "\t\tunexport create createWithNamespace\n"
 "\t\tmethod new args {\n"
 "\t\t\tif {![info exists object] || ![info object isa object $object]} {\n"
@@ -231,7 +204,7 @@ static const char *tclOOSetupScript =
 "\t\t}\n"
 "\t}\n"
 "\tclass create abstract {\n"
-"\t\tsuperclass class\n"
+"\t\tsuperclass -set class\n"
 "\t\tunexport create createWithNamespace new\n"
 "\t}\n"
 "\tnamespace eval configuresupport::configurableclass {\n"
@@ -249,7 +222,7 @@ static const char *tclOOSetupScript =
 "\t\tdefinitionnamespace -class configuresupport::configurableclass\n"
 "\t}\n"
 "\tclass create configurable {\n"
-"\t\tsuperclass class\n"
+"\t\tsuperclass -set class\n"
 "\t\tconstructor {{definitionScript \"\"}} {\n"
 "\t\t\tnext {mixin ::oo::configuresupport::configurable}\n"
 "\t\t\tnext $definitionScript\n"
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 442756d..f2fcfd5 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -198,47 +198,6 @@
     define Slot {
 	# ------------------------------------------------------------------
 	#
-	# Slot Get --
-	#
-	#	Basic slot getter. Retrieves the contents of the slot.
-	#	Particular slots must provide concrete non-erroring
-	#	implementation.
-	#
-	# ------------------------------------------------------------------
-
-	method Get -unexport {} {
-	    return -code error -errorcode {TCL OO ABSTRACT_SLOT} "unimplemented"
-	}
-
-	# ------------------------------------------------------------------
-	#
-	# Slot Set --
-	#
-	#	Basic slot setter. Sets the contents of the slot.  Particular
-	#	slots must provide concrete non-erroring implementation.
-	#
-	# ------------------------------------------------------------------
-
-	method Set -unexport list {
-	    return -code error -errorcode {TCL OO ABSTRACT_SLOT} "unimplemented"
-	}
-
-	# ------------------------------------------------------------------
-	#
-	# Slot Resolve --
-	#
-	#	Helper that lets a slot convert a list of arguments of a
-	#	particular type to their canonical forms. Defaults to doing
-	#	nothing (suitable for simple strings).
-	#
-	# ------------------------------------------------------------------
-
-	method Resolve -unexport list {
-	    return $list
-	}
-
-	# ------------------------------------------------------------------
-	#
 	# Slot -set, -append, -clear, --default-operation --
 	#
 	#	Standard public slot operations. If a slot can't figure out
@@ -246,17 +205,6 @@
 	#
 	# ------------------------------------------------------------------
 
-	method -set -export args {
-	    set my [namespace which my]
-	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
-	    tailcall my Set $args
-	}
-	method -append -export args {
-	    set my [namespace which my]
-	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
-	    set current [uplevel 1 [list $my Get]]
-	    tailcall my Set [list {*}$current {*}$args]
-	}
 	method -appendifnew -export args {
 	    set my [namespace which my]
 	    set current [uplevel 1 [list $my Get]]
@@ -268,13 +216,6 @@
 	    }
 	    tailcall my Set $current
 	}
-	method -clear -export {} {tailcall my Set {}}
-	method -prepend -export args {
-	    set my [namespace which my]
-	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
-	    set current [uplevel 1 [list $my Get]]
-	    tailcall my Set [list {*}$args {*}$current]
-	}
 	method -remove -export args {
 	    set my [namespace which my]
 	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
@@ -372,8 +313,8 @@
     # ----------------------------------------------------------------------
 
     class create singleton {
-	superclass class
-	variable object
+	superclass -set class
+	variable -set object
 	unexport create createWithNamespace
 	method new args {
 	    if {![info exists object] || ![info object isa object $object]} {
@@ -403,7 +344,7 @@
     # ----------------------------------------------------------------------
 
     class create abstract {
-	superclass class
+	superclass -set class
 	unexport create createWithNamespace new
     }
 
@@ -486,7 +427,7 @@
     # ----------------------------------------------------------------------
 
     class create configurable {
-	superclass class
+	superclass -set class
 
 	constructor {{definitionScript ""}} {
 	    next {mixin ::oo::configuresupport::configurable}
-- 
cgit v0.12


From 9582b7a00571f524b4f51e8fd3ee4bd979215db9 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 19 Aug 2025 09:00:02 +0000
Subject: Speed up TclOO init; no directing via unknown method handler for
 slots of classes we define ourselves

---
 generic/tclOOScript.h | 8 ++++----
 tools/tclOOScript.tcl | 8 ++++----
 2 files changed, 8 insertions(+), 8 deletions(-)

diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 7b8a69d..a9b262c 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -210,8 +210,8 @@ static const char *tclOOSetupScript =
 "\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
 "\t}\n"
 "\tclass create singleton {\n"
-"\t\tsuperclass class\n"
-"\t\tvariable object\n"
+"\t\tsuperclass -set class\n"
+"\t\tvariable -set object\n"
 "\t\tunexport create createWithNamespace\n"
 "\t\tmethod new args {\n"
 "\t\t\tif {![info exists object] || ![info object isa object $object]} {\n"
@@ -231,7 +231,7 @@ static const char *tclOOSetupScript =
 "\t\t}\n"
 "\t}\n"
 "\tclass create abstract {\n"
-"\t\tsuperclass class\n"
+"\t\tsuperclass -set class\n"
 "\t\tunexport create createWithNamespace new\n"
 "\t}\n"
 "\tnamespace eval configuresupport::configurableclass {\n"
@@ -249,7 +249,7 @@ static const char *tclOOSetupScript =
 "\t\tdefinitionnamespace -class configuresupport::configurableclass\n"
 "\t}\n"
 "\tclass create configurable {\n"
-"\t\tsuperclass class\n"
+"\t\tsuperclass -set class\n"
 "\t\tconstructor {{definitionScript \"\"}} {\n"
 "\t\t\tnext {mixin ::oo::configuresupport::configurable}\n"
 "\t\t\tnext $definitionScript\n"
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 442756d..542b711 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -372,8 +372,8 @@
     # ----------------------------------------------------------------------
 
     class create singleton {
-	superclass class
-	variable object
+	superclass -set class
+	variable -set object
 	unexport create createWithNamespace
 	method new args {
 	    if {![info exists object] || ![info object isa object $object]} {
@@ -403,7 +403,7 @@
     # ----------------------------------------------------------------------
 
     class create abstract {
-	superclass class
+	superclass -set class
 	unexport create createWithNamespace new
     }
 
@@ -486,7 +486,7 @@
     # ----------------------------------------------------------------------
 
     class create configurable {
-	superclass class
+	superclass -set class
 
 	constructor {{definitionScript ""}} {
 	    next {mixin ::oo::configuresupport::configurable}
-- 
cgit v0.12


From 2d4422bbbaaea2c7d45ecb8af256c8b6c548f568 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 19 Aug 2025 13:51:54 +0000
Subject: Saner C implementation of slot methods; add unknown handler to C side

---
 generic/tclOO.c           |  12 ++
 generic/tclOODefineCmds.c | 345 +++++++++++++++++++++-------------------------
 generic/tclOOInt.h        |   4 +
 generic/tclOOScript.h     |   9 --
 tools/tclOOScript.tcl     |  11 +-
 5 files changed, 176 insertions(+), 205 deletions(-)

diff --git a/generic/tclOO.c b/generic/tclOO.c
index e1dd40f..1e8012f 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -371,6 +371,10 @@ InitFoundation(
     TclNewLiteralStringObj(fPtr->defineName, "::oo::define");
     TclNewLiteralStringObj(fPtr->myName, "my");
     TclNewLiteralStringObj(fPtr->mcdName, "::oo::MixinClassDelegates");
+    TclNewLiteralStringObj(fPtr->slotGetName, "Get");
+    TclNewLiteralStringObj(fPtr->slotSetName, "Set");
+    TclNewLiteralStringObj(fPtr->slotResolveName, "Resolve");
+    TclNewLiteralStringObj(fPtr->slotDefOpName, "--default-operation");
     Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
     Tcl_IncrRefCount(fPtr->constructorName);
     Tcl_IncrRefCount(fPtr->destructorName);
@@ -378,6 +382,10 @@ InitFoundation(
     Tcl_IncrRefCount(fPtr->defineName);
     Tcl_IncrRefCount(fPtr->myName);
     Tcl_IncrRefCount(fPtr->mcdName);
+    Tcl_IncrRefCount(fPtr->slotGetName);
+    Tcl_IncrRefCount(fPtr->slotSetName);
+    Tcl_IncrRefCount(fPtr->slotResolveName);
+    Tcl_IncrRefCount(fPtr->slotDefOpName);
 
     TclCreateObjCommandInNs(interp, "UnknownDefinition", fPtr->ooNs,
 	    TclOOUnknownDefinition, NULL, NULL);
@@ -621,6 +629,10 @@ KillFoundation(
     TclDecrRefCount(fPtr->defineName);
     TclDecrRefCount(fPtr->myName);
     TclDecrRefCount(fPtr->mcdName);
+    TclDecrRefCount(fPtr->slotGetName);
+    TclDecrRefCount(fPtr->slotSetName);
+    TclDecrRefCount(fPtr->slotResolveName);
+    TclDecrRefCount(fPtr->slotDefOpName);
     TclOODecrRefCount(fPtr->objectCls->thisPtr);
     TclOODecrRefCount(fPtr->classCls->thisPtr);
 
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 0395599..fc7e479 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -88,7 +88,7 @@ static inline void	RecomputeClassCacheFlag(Object *oPtr);
 static int		RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
 			    int useClass, Tcl_Obj *const fromPtr,
 			    Tcl_Obj *const toPtr);
-static int		Slot_Append(void *clientData,
+static int		Slot_Append(void *,
 			    Tcl_Interp *interp, Tcl_ObjectContext context,
 			    int objc, Tcl_Obj *const *objv);
 #if 0 // TODO
@@ -96,10 +96,10 @@ static int		Slot_AppendNew(void *clientData,
 			    Tcl_Interp *interp, Tcl_ObjectContext context,
 			    int objc, Tcl_Obj *const *objv);
 #endif
-static int		Slot_Clear(void *clientData,
+static int		Slot_Clear(void *,
 			    Tcl_Interp *interp, Tcl_ObjectContext context,
 			    int objc, Tcl_Obj *const *objv);
-static int		Slot_Prepend(void *clientData,
+static int		Slot_Prepend(void *,
 			    Tcl_Interp *interp, Tcl_ObjectContext context,
 			    int objc, Tcl_Obj *const *objv);
 #if 0 // TODO
@@ -107,20 +107,18 @@ static int		Slot_Remove(void *clientData,
 			    Tcl_Interp *interp, Tcl_ObjectContext context,
 			    int objc, Tcl_Obj *const *objv);
 #endif
-static int		Slot_Resolve(void *clientData,
+static int		Slot_Resolve(void *,
 			    Tcl_Interp *interp, Tcl_ObjectContext context,
 			    int objc, Tcl_Obj *const *objv);
-static int		Slot_Set(void *clientData,
+static int		Slot_Set(void *,
 			    Tcl_Interp *interp, Tcl_ObjectContext context,
 			    int objc, Tcl_Obj *const *objv);
-static int		Slot_Unimplemented(void *clientData,
+static int		Slot_Unimplemented(void *,
+			    Tcl_Interp *interp, Tcl_ObjectContext,
+			    int, Tcl_Obj *const *);
+static int		Slot_Unknown(void *,
 			    Tcl_Interp *interp, Tcl_ObjectContext context,
 			    int objc, Tcl_Obj *const *objv);
-#if 0 // TODO
-static int		Slot_Unknown(void *clientData,
-			    Tcl_Interp *interp, Tcl_ObjectContext context,
-			    int objc, Tcl_Obj *const *objv);
-#endif
 static int		ClassFilter_Get(void *clientData,
 			    Tcl_Interp *interp, Tcl_ObjectContext context,
 			    int objc, Tcl_Obj *const *objv);
@@ -226,10 +224,10 @@ static const DeclaredSlotMethod slotMethods[] = {
     SLOT_METHOD("-clear",	Slot_Clear,	PUBLIC_METHOD),
     SLOT_METHOD("-prepend",	Slot_Prepend,	PUBLIC_METHOD),
     SLOT_METHOD("-set",		Slot_Set,	PUBLIC_METHOD),
+    SLOT_METHOD("unknown",	Slot_Unknown,	0),
 #if 0 // TODO
     SLOT_METHOD("-appendifnew",	Slot_AppendNew,	PUBLIC_METHOD),
     SLOT_METHOD("-remove",	Slot_Remove,	PUBLIC_METHOD),
-    SLOT_METHOD("unknown",	Slot_Unknown,	0),
 #endif
     {NULL, 0, {0, 0, 0, 0, 0}}
 };
@@ -2475,10 +2473,6 @@ TclOODefineSlots(
 	Tcl_BounceRefCount(name);
     }
 
-    Tcl_Obj *getName, *setName, *resolveName;
-    TclNewLiteralStringObj(getName, "Get");
-    TclNewLiteralStringObj(setName, "Set");
-    TclNewLiteralStringObj(resolveName, "Resolve");
     for (const DeclaredSlot *slotPtr = slots ; slotPtr->name ; slotPtr++) {
 	Tcl_Object slotObject = Tcl_NewObjectInstance(interp,
 		slotCls, slotPtr->name, NULL, TCL_INDEX_NONE, NULL, 0);
@@ -2486,21 +2480,87 @@ TclOODefineSlots(
 	if (slotObject == NULL) {
 	    continue;
 	}
-	TclNewInstanceMethod(interp, slotObject, getName, 0,
+	TclNewInstanceMethod(interp, slotObject, fPtr->slotGetName, 0,
 		&slotPtr->getterType, NULL);
-	TclNewInstanceMethod(interp, slotObject, setName, 0,
+	TclNewInstanceMethod(interp, slotObject, fPtr->slotSetName, 0,
 		&slotPtr->setterType, NULL);
 	if (slotPtr->resolverType.callProc) {
-	    TclNewInstanceMethod(interp, slotObject, resolveName, 0,
+	    TclNewInstanceMethod(interp, slotObject, fPtr->slotResolveName, 0,
 		    &slotPtr->resolverType, NULL);
 	}
     }
-    Tcl_BounceRefCount(getName);
-    Tcl_BounceRefCount(setName);
-    Tcl_BounceRefCount(resolveName);
     return TCL_OK;
 }
 
+static inline int
+CallSlotGet(
+    Tcl_Interp *interp,
+    Object *oPtr)
+{
+    Tcl_Obj *getArgs[] = {
+	oPtr->fPtr->myName,
+	oPtr->fPtr->slotGetName
+    };
+    return TclOOPrivateObjectCmd(oPtr, interp, 2, getArgs);
+}
+
+static inline int
+CallSlotSet(
+    Tcl_Interp *interp,
+    Object *oPtr,
+    Tcl_Obj *list)
+{
+    Tcl_Obj *setArgs[] = {
+	oPtr->fPtr->myName,
+	oPtr->fPtr->slotSetName,
+	list
+    };
+    return TclOOPrivateObjectCmd(oPtr, interp, 3, setArgs);
+}
+
+static inline int
+CallSlotResolve(
+    Tcl_Interp *interp,
+    Object *oPtr,
+    Tcl_Obj *item)
+{
+    Tcl_Obj *resolveArgs[] = {
+	oPtr->fPtr->myName,
+	oPtr->fPtr->slotResolveName,
+	item
+    };
+    return TclOOPrivateObjectCmd(oPtr, interp, 3, resolveArgs);
+}
+
+static inline Tcl_Obj *
+ResolveAll(
+    Tcl_Interp *interp,
+    Object *oPtr,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Tcl_Obj **resolvedItems = (Tcl_Obj **) TclStackAlloc(interp,
+	    sizeof(Tcl_Obj *) * objc);
+    for (int i = 0; i < objc; i++) {
+	if (CallSlotResolve(interp, oPtr, objv[i]) != TCL_OK) {
+	    for (int j = 0; j < i; j++) {
+		Tcl_DecrRefCount(resolvedItems[j]);
+	    }
+	    TclStackFree(interp, (void *) resolvedItems);
+	    return NULL;
+	}
+	resolvedItems[i] = Tcl_GetObjResult(interp);
+	Tcl_IncrRefCount(resolvedItems[i]);
+	Tcl_ResetResult(interp);
+    }
+    Tcl_Obj *resolvedList = Tcl_NewListObj(objc, resolvedItems);
+    for (int i = 0; i < objc; i++) {
+	TclDecrRefCount(resolvedItems[i]);
+    }
+    TclStackFree(interp, (void *) resolvedItems);
+    return resolvedList;
+}
+
 static int
 Slot_Append(
     TCL_UNUSED(void *),
@@ -2510,84 +2570,43 @@ Slot_Append(
     Tcl_Obj *const *objv)
 {
     Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
-    if (Tcl_ObjectContextSkippedArgs(context) == objc) {
+    int skip = Tcl_ObjectContextSkippedArgs(context);
+    if (skip == objc) {
 	return TCL_OK;
     }
-    objc -= Tcl_ObjectContextSkippedArgs(context);
-    objv += Tcl_ObjectContextSkippedArgs(context);
-
-    Tcl_Obj *args[3];
-    args[0] = Tcl_NewStringObj("my", -1);
-    Tcl_IncrRefCount(args[0]);
 
     // Resolve all values
-    Tcl_Obj **resolved = (Tcl_Obj **)
-	    TclStackAlloc(interp, sizeof(Tcl_Obj *) * objc);
-    args[1] = Tcl_NewStringObj("Resolve", -1);
-    Tcl_IncrRefCount(args[1]);
-    for (int i = 0; i < objc; i++) {
-	args[2] = objv[i];
-	if (TclOOPrivateObjectCmd(oPtr, interp, 3, args) != TCL_OK) {
-	    Tcl_DecrRefCount(args[0]);
-	    Tcl_DecrRefCount(args[1]);
-	    for (int j = 0; j < i; j++) {
-		Tcl_DecrRefCount(resolved[j]);
-	    }
-	    TclStackFree(interp, (void *) resolved);
-	    return TCL_ERROR;
-	}
-	resolved[i] = Tcl_GetObjResult(interp);
-	Tcl_IncrRefCount(resolved[i]);
-	Tcl_ResetResult(interp);
+    Tcl_Obj *resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip);
+    if (resolved == NULL) {
+	return TCL_ERROR;
     }
-    Tcl_DecrRefCount(args[1]);
 
-    // Get slot contents; store in args[2]
-    args[1] = Tcl_NewStringObj("Get", -1);
-    Tcl_IncrRefCount(args[1]);
-    if (TclOOPrivateObjectCmd(oPtr, interp, 2, args) != TCL_OK) {
-	Tcl_DecrRefCount(args[0]);
-	Tcl_DecrRefCount(args[1]);
-	for (int j = 0; j < objc; j++) {
-	    Tcl_DecrRefCount(resolved[j]);
-	}
-	TclStackFree(interp, (void *) resolved);
+    // Get slot contents; store in list
+    if (CallSlotGet(interp, oPtr) != TCL_OK) {
+	Tcl_DecrRefCount(resolved);
 	return TCL_ERROR;
     }
-    args[2] = Tcl_GetObjResult(interp);
-    Tcl_IncrRefCount(args[2]);
-    Tcl_DecrRefCount(args[1]);
+    Tcl_Obj *list = Tcl_GetObjResult(interp);
+    Tcl_IncrRefCount(list);
     Tcl_ResetResult(interp);
 
     // Append
-    if (Tcl_IsShared(args[2])) {
-	Tcl_Obj *dup = Tcl_DuplicateObj(args[2]);
+    if (Tcl_IsShared(list)) {
+	Tcl_Obj *dup = Tcl_DuplicateObj(list);
 	Tcl_IncrRefCount(dup);
-	Tcl_DecrRefCount(args[2]);
-	args[2] = dup;
+	Tcl_DecrRefCount(list);
+	list = dup;
     }
-    if (TclListObjAppendElements(interp, args[2], objc, resolved) != TCL_OK) {
-	Tcl_DecrRefCount(args[0]);
-	Tcl_DecrRefCount(args[2]);
-	for (int j = 0; j < objc; j++) {
-	    Tcl_DecrRefCount(resolved[j]);
-	}
-	TclStackFree(interp, (void *) resolved);
+    if (Tcl_ListObjAppendList(interp, list, resolved) != TCL_OK) {
+	Tcl_DecrRefCount(list);
+	Tcl_DecrRefCount(resolved);
 	return TCL_ERROR;
     }
-    for (int j = 0; j < objc; j++) {
-	Tcl_DecrRefCount(resolved[j]);
-    }
-    TclStackFree(interp, (void *) resolved);
-    // resolved is now non-referenceable
+    Tcl_DecrRefCount(resolved);
 
     // Set slot contents
-    args[1] = Tcl_NewStringObj("Set", -1);
-    Tcl_IncrRefCount(args[1]);
-    int code = TclOOPrivateObjectCmd(oPtr, interp, 3, args);
-    Tcl_DecrRefCount(args[0]);
-    Tcl_IncrRefCount(args[1]);
-    Tcl_IncrRefCount(args[2]);
+    int code = CallSlotSet(interp, oPtr, list);
+    Tcl_DecrRefCount(list);
     return code;
 }
 
@@ -2600,23 +2619,15 @@ Slot_Clear(
     Tcl_Obj *const *objv)
 {
     Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
-    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
-	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
-		NULL);
+    int skip = Tcl_ObjectContextSkippedArgs(context);
+    if (skip != objc) {
+	Tcl_WrongNumArgs(interp, skip, objv, NULL);
 	return TCL_ERROR;
     }
-    Tcl_Obj *args[] = {
-	Tcl_NewStringObj("my", -1),
-	Tcl_NewStringObj("Set", -1),
-	Tcl_NewObj()
-    };
-    Tcl_IncrRefCount(args[0]);
-    Tcl_IncrRefCount(args[1]);
-    Tcl_IncrRefCount(args[2]);
-    int code = TclOOPrivateObjectCmd(oPtr, interp, 3, args);
-    Tcl_DecrRefCount(args[0]);
-    Tcl_IncrRefCount(args[1]);
-    Tcl_IncrRefCount(args[2]);
+    Tcl_Obj *list = Tcl_NewObj();
+    Tcl_IncrRefCount(list);
+    int code = CallSlotSet(interp, oPtr, list);
+    Tcl_DecrRefCount(list);
     return code;
 }
 
@@ -2629,51 +2640,20 @@ Slot_Prepend(
     Tcl_Obj *const *objv)
 {
     Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
-    if (Tcl_ObjectContextSkippedArgs(context) == objc) {
+    int skip = Tcl_ObjectContextSkippedArgs(context);
+    if (skip == objc) {
 	return TCL_OK;
     }
-    objc -= Tcl_ObjectContextSkippedArgs(context);
-    objv += Tcl_ObjectContextSkippedArgs(context);
-
-    Tcl_Obj *args[3];
-    args[0] = Tcl_NewStringObj("my", -1);
-    Tcl_IncrRefCount(args[0]);
 
     // Resolve all values
-    Tcl_Obj **resolved = (Tcl_Obj **)
-	    TclStackAlloc(interp, sizeof(Tcl_Obj *) * objc);
-    args[1] = Tcl_NewStringObj("Resolve", -1);
-    Tcl_IncrRefCount(args[1]);
-    for (int i = 0; i < objc; i++) {
-	args[2] = objv[i];
-	if (TclOOPrivateObjectCmd(oPtr, interp, 3, args) != TCL_OK) {
-	    Tcl_DecrRefCount(args[0]);
-	    Tcl_DecrRefCount(args[1]);
-	    for (int j = 0; j < i; j++) {
-		Tcl_DecrRefCount(resolved[j]);
-	    }
-	    TclStackFree(interp, (void *) resolved);
-	    return TCL_ERROR;
-	}
-	resolved[i] = Tcl_GetObjResult(interp);
-	Tcl_IncrRefCount(resolved[i]);
-	Tcl_ResetResult(interp);
+    Tcl_Obj *list = ResolveAll(interp, oPtr, objc - skip, objv + skip);
+    if (list == NULL) {
+	return TCL_ERROR;
     }
-    Tcl_DecrRefCount(args[1]);
-    Tcl_Obj *list = Tcl_NewListObj(objc, resolved);
     Tcl_IncrRefCount(list);
-    for (int j = 0; j < objc; j++) {
-	Tcl_DecrRefCount(resolved[j]);
-    }
-    TclStackFree(interp, (void *) resolved);
-    // resolved is now non-referenceable
 
     // Get slot contents and append to list
-    args[1] = Tcl_NewStringObj("Get", -1);
-    Tcl_IncrRefCount(args[1]);
-    if (TclOOPrivateObjectCmd(oPtr, interp, 2, args) != TCL_OK) {
-	Tcl_DecrRefCount(args[0]);
-	Tcl_DecrRefCount(args[1]);
+    if (CallSlotGet(interp, oPtr) != TCL_OK) {
 	Tcl_DecrRefCount(list);
 	return TCL_ERROR;
     }
@@ -2681,13 +2661,8 @@ Slot_Prepend(
     Tcl_ResetResult(interp);
 
     // Set slot contents
-    args[1] = Tcl_NewStringObj("Set", -1);
-    args[2] = list; // Already has a ref
-    Tcl_IncrRefCount(args[1]);
-    int code = TclOOPrivateObjectCmd(oPtr, interp, 3, args);
-    Tcl_DecrRefCount(args[0]);
-    Tcl_IncrRefCount(args[1]);
-    Tcl_IncrRefCount(args[2]);
+    int code = CallSlotSet(interp, oPtr, list);
+    Tcl_DecrRefCount(list);
     return code;
 }
 
@@ -2699,9 +2674,9 @@ Slot_Resolve(
     int objc,
     Tcl_Obj *const *objv)
 {
-    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
-	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
-		"list");
+    int skip = Tcl_ObjectContextSkippedArgs(context);
+    if (skip + 1 != objc) {
+	Tcl_WrongNumArgs(interp, skip, objv, "list");
 	return TCL_ERROR;
     }
     Tcl_SetObjResult(interp, objv[objc - 1]);
@@ -2717,54 +2692,23 @@ Slot_Set(
     Tcl_Obj *const *objv)
 {
     Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
-    if (Tcl_ObjectContextSkippedArgs(context) == objc) {
-	return TCL_OK;
-    }
-    objc -= Tcl_ObjectContextSkippedArgs(context);
-    objv += Tcl_ObjectContextSkippedArgs(context);
-
-    Tcl_Obj *args[3];
-    args[0] = Tcl_NewStringObj("my", -1);
-    Tcl_IncrRefCount(args[0]);
+    int skip = Tcl_ObjectContextSkippedArgs(context);
+    Tcl_Obj *list;
 
     // Resolve all values
-    Tcl_Obj **resolved = (Tcl_Obj **)
-	    TclStackAlloc(interp, sizeof(Tcl_Obj *) * objc);
-    args[1] = Tcl_NewStringObj("Resolve", -1);
-    Tcl_IncrRefCount(args[1]);
-    for (int i = 0; i < objc; i++) {
-	args[2] = objv[i];
-	if (TclOOPrivateObjectCmd(oPtr, interp, 3, args) != TCL_OK) {
-	    Tcl_DecrRefCount(args[0]);
-	    Tcl_DecrRefCount(args[1]);
-	    for (int j = 0; j < i; j++) {
-		Tcl_DecrRefCount(resolved[j]);
-	    }
-	    TclStackFree(interp, (void *) resolved);
+    if (skip == objc) {
+	list = Tcl_NewObj();
+    } else {
+	list = ResolveAll(interp, oPtr, objc - skip, objv + skip);
+	if (list == NULL) {
 	    return TCL_ERROR;
 	}
-	resolved[i] = Tcl_GetObjResult(interp);
-	Tcl_IncrRefCount(resolved[i]);
-	Tcl_ResetResult(interp);
-    }
-    Tcl_DecrRefCount(args[1]);
-
-    // Make a list
-    args[2] = Tcl_NewListObj(objc, resolved);
-    Tcl_IncrRefCount(args[2]);
-    for (int j = 0; j < objc; j++) {
-	Tcl_DecrRefCount(resolved[j]);
     }
-    TclStackFree(interp, (void *) resolved);
-    // resolved is now non-referenceable
+    Tcl_IncrRefCount(list);
 
     // Set slot contents
-    args[1] = Tcl_NewStringObj("Set", -1);
-    Tcl_IncrRefCount(args[1]);
-    int code = TclOOPrivateObjectCmd(oPtr, interp, 3, args);
-    Tcl_DecrRefCount(args[0]);
-    Tcl_IncrRefCount(args[1]);
-    Tcl_IncrRefCount(args[2]);
+    int code = CallSlotSet(interp, oPtr, list);
+    Tcl_DecrRefCount(list);
     return code;
 }
 
@@ -2780,6 +2724,35 @@ Slot_Unimplemented(
     OO_ERROR(interp, ABSTRACT_SLOT);
     return TCL_ERROR;
 }
+
+static int
+Slot_Unknown(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+    int skip = Tcl_ObjectContextSkippedArgs(context);
+    if (skip >= objc) {
+	Tcl_Obj *args[] = {
+	    oPtr->fPtr->myName,
+	    oPtr->fPtr->slotDefOpName
+	};
+	return TclOOPrivateObjectCmd(oPtr, interp, 2, args);
+    } else if (TclGetString(objv[skip])[0] != '-') {
+	Tcl_Obj **args = (Tcl_Obj **) TclStackAlloc(interp,
+		sizeof(Tcl_Obj *) * (objc - skip + 2));
+	args[0] = oPtr->fPtr->myName;
+	args[1] = oPtr->fPtr->slotDefOpName;
+	memcpy(args+2, objv+skip, sizeof(Tcl_Obj*) * (objc - skip));
+	int code = TclOOPrivateObjectCmd(oPtr, interp, objc - skip + 2, args);
+	TclStackFree(interp, args);
+	return code;
+    }
+    return TclNRObjectContextInvokeNext(interp, context, objc, objv, skip);
+}
 
 /*
  * ----------------------------------------------------------------------
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index e4351f6..94eda61 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -407,6 +407,10 @@ struct Foundation {
     Tcl_Obj *myName;		/* The "my" shared object. */
     Tcl_Obj *mcdName;		/* The shared object for calling the helper to
 				 * mix in class delegates. */
+    Tcl_Obj *slotGetName;	/* The "Get" name used by slots. */
+    Tcl_Obj *slotSetName;	/* The "Set" name used by slots. */
+    Tcl_Obj *slotResolveName;	/* The "Resolve" name used by slots. */
+    Tcl_Obj *slotDefOpName;	/* The "--default-operation" name used by slots. */
 };
 
 /*
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 796a5cf..9b1de48 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -137,15 +137,6 @@ static const char *tclOOSetupScript =
 "\t\t\t}]\n"
 "\t\t}\n"
 "\t\tforward --default-operation my -append\n"
-"\t\tmethod unknown -unexport {args} {\n"
-"\t\t\tset def --default-operation\n"
-"\t\t\tif {[llength $args] == 0} {\n"
-"\t\t\t\ttailcall my $def\n"
-"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n"
-"\t\t\t\ttailcall my $def {*}$args\n"
-"\t\t\t}\n"
-"\t\t\tnext {*}$args\n"
-"\t\t}\n"
 "\t\tunexport destroy\n"
 "\t}\n"
 "\tobjdefine define::superclass forward --default-operation my -set\n"
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index f2fcfd5..535c56c 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -198,7 +198,7 @@
     define Slot {
 	# ------------------------------------------------------------------
 	#
-	# Slot -set, -append, -clear, --default-operation --
+	# Slot -appendifnew, -remove, --default-operation --
 	#
 	#	Standard public slot operations. If a slot can't figure out
 	#	what method to call directly, it uses --default-operation.
@@ -227,15 +227,6 @@
 
 	# Default handling
 	forward --default-operation my -append
-	method unknown -unexport {args} {
-	    set def --default-operation
-	    if {[llength $args] == 0} {
-		tailcall my $def
-	    } elseif {![string match -* [lindex $args 0]]} {
-		tailcall my $def {*}$args
-	    }
-	    next {*}$args
-	}
 
 	# Hide destroy
 	unexport destroy
-- 
cgit v0.12


From dde7348f8642b86ddeaf6e386962d0691fb84ca9 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 19 Aug 2025 14:15:18 +0000
Subject: Add remoaining slot ops

---
 generic/tclOODefineCmds.c | 143 ++++++++++++++++++++++++++++++++++++++++++----
 generic/tclOOScript.h     |  19 ------
 tools/tclOOScript.tcl     |  26 +--------
 3 files changed, 136 insertions(+), 52 deletions(-)

diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index fc7e479..0c4d328 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -91,22 +91,18 @@ static int		RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
 static int		Slot_Append(void *,
 			    Tcl_Interp *interp, Tcl_ObjectContext context,
 			    int objc, Tcl_Obj *const *objv);
-#if 0 // TODO
-static int		Slot_AppendNew(void *clientData,
+static int		Slot_AppendNew(void *,
 			    Tcl_Interp *interp, Tcl_ObjectContext context,
 			    int objc, Tcl_Obj *const *objv);
-#endif
 static int		Slot_Clear(void *,
 			    Tcl_Interp *interp, Tcl_ObjectContext context,
 			    int objc, Tcl_Obj *const *objv);
 static int		Slot_Prepend(void *,
 			    Tcl_Interp *interp, Tcl_ObjectContext context,
 			    int objc, Tcl_Obj *const *objv);
-#if 0 // TODO
-static int		Slot_Remove(void *clientData,
+static int		Slot_Remove(void *,
 			    Tcl_Interp *interp, Tcl_ObjectContext context,
 			    int objc, Tcl_Obj *const *objv);
-#endif
 static int		Slot_Resolve(void *,
 			    Tcl_Interp *interp, Tcl_ObjectContext context,
 			    int objc, Tcl_Obj *const *objv);
@@ -221,14 +217,12 @@ static const DeclaredSlotMethod slotMethods[] = {
     SLOT_METHOD("Resolve",	Slot_Resolve,	0),
     SLOT_METHOD("Set",		Slot_Unimplemented, 0),
     SLOT_METHOD("-append",	Slot_Append,	PUBLIC_METHOD),
+    SLOT_METHOD("-appendifnew",	Slot_AppendNew,	PUBLIC_METHOD),
     SLOT_METHOD("-clear",	Slot_Clear,	PUBLIC_METHOD),
     SLOT_METHOD("-prepend",	Slot_Prepend,	PUBLIC_METHOD),
+    SLOT_METHOD("-remove",	Slot_Remove,	PUBLIC_METHOD),
     SLOT_METHOD("-set",		Slot_Set,	PUBLIC_METHOD),
     SLOT_METHOD("unknown",	Slot_Unknown,	0),
-#if 0 // TODO
-    SLOT_METHOD("-appendifnew",	Slot_AppendNew,	PUBLIC_METHOD),
-    SLOT_METHOD("-remove",	Slot_Remove,	PUBLIC_METHOD),
-#endif
     {NULL, 0, {0, 0, 0, 0, 0}}
 };
 
@@ -2611,6 +2605,73 @@ Slot_Append(
 }
 
 static int
+Slot_AppendNew(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+    int skip = Tcl_ObjectContextSkippedArgs(context);
+    if (skip == objc) {
+	return TCL_OK;
+    }
+
+    // Resolve all values
+    Tcl_Obj *resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip);
+    if (resolved == NULL) {
+	return TCL_ERROR;
+    }
+
+    // Get slot contents; store in list
+    if (CallSlotGet(interp, oPtr) != TCL_OK) {
+	Tcl_DecrRefCount(resolved);
+	return TCL_ERROR;
+    }
+    Tcl_Obj *list = Tcl_GetObjResult(interp);
+    Tcl_IncrRefCount(list);
+    Tcl_ResetResult(interp);
+
+    // Prepare a set of items in the list to set
+    Tcl_Size listc;
+    Tcl_Obj **listv;
+    if (TclListObjGetElements(interp, list, &listc, &listv) != TCL_OK) {
+	Tcl_DecrRefCount(list);
+	Tcl_DecrRefCount(resolved);
+	return TCL_ERROR;
+    }
+    Tcl_HashTable unique;
+    Tcl_InitObjHashTable(&unique);
+    for (Tcl_Size i=0 ; i<listc; i++) {
+	Tcl_CreateHashEntry(&unique, listv[i], NULL);
+    }
+
+    // Append the new items if they're not already there
+    if (Tcl_IsShared(list)) {
+	Tcl_Obj *dup = Tcl_DuplicateObj(list);
+	Tcl_IncrRefCount(dup);
+	Tcl_DecrRefCount(list);
+	list = dup;
+    }
+    TclListObjGetElements(NULL, resolved, &listc, &listv);
+    for (Tcl_Size i=0 ; i<listc; i++) {
+	int isNew;
+	Tcl_CreateHashEntry(&unique, listv[i], &isNew);
+	if (isNew) {
+	    Tcl_ListObjAppendElement(interp, list, listv[i]);
+	}
+    }
+    Tcl_DecrRefCount(resolved);
+    Tcl_DeleteHashTable(&unique);
+
+    // Set slot contents
+    int code = CallSlotSet(interp, oPtr, list);
+    Tcl_DecrRefCount(list);
+    return code;
+}
+
+static int
 Slot_Clear(
     TCL_UNUSED(void *),
     Tcl_Interp *interp,
@@ -2667,6 +2728,68 @@ Slot_Prepend(
 }
 
 static int
+Slot_Remove(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+    int skip = Tcl_ObjectContextSkippedArgs(context);
+    if (skip == objc) {
+	return TCL_OK;
+    }
+
+    // Resolve all values
+    Tcl_Obj *resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip);
+    if (resolved == NULL) {
+	return TCL_ERROR;
+    }
+
+    // Get slot contents; store in list
+    if (CallSlotGet(interp, oPtr) != TCL_OK) {
+	Tcl_DecrRefCount(resolved);
+	return TCL_ERROR;
+    }
+    Tcl_Obj *oldList = Tcl_GetObjResult(interp);
+    Tcl_IncrRefCount(oldList);
+    Tcl_ResetResult(interp);
+
+    // Prepare a set of items in the list to remove
+    Tcl_Size listc;
+    Tcl_Obj **listv;
+    TclListObjGetElements(NULL, resolved, &listc, &listv);
+    Tcl_HashTable removeSet;
+    Tcl_InitObjHashTable(&removeSet);
+    for (Tcl_Size i=0 ; i<listc; i++) {
+	Tcl_CreateHashEntry(&removeSet, listv[i], NULL);
+    }
+    Tcl_DecrRefCount(resolved);
+
+    // Append the new items from the old items if they're not in the remove set
+    if (TclListObjGetElements(interp, oldList, &listc, &listv) != TCL_OK) {
+	Tcl_DecrRefCount(oldList);
+	Tcl_DeleteHashTable(&removeSet);
+	return TCL_ERROR;
+    }
+    Tcl_Obj *newList = Tcl_NewObj();
+    for (Tcl_Size i=0 ; i<listc; i++) {
+	if (Tcl_FindHashEntry(&removeSet, listv[i]) == NULL) {
+	    Tcl_ListObjAppendElement(NULL, newList, listv[i]);
+	}
+    }
+    Tcl_DecrRefCount(oldList);
+    Tcl_DeleteHashTable(&removeSet);
+
+    // Set slot contents
+    Tcl_IncrRefCount(newList);
+    int code = CallSlotSet(interp, oPtr, newList);
+    Tcl_DecrRefCount(newList);
+    return code;
+}
+
+static int
 Slot_Resolve(
     TCL_UNUSED(void *),
     Tcl_Interp *interp,
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 9b1de48..80c4c68 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -117,25 +117,6 @@ static const char *tclOOSetupScript =
 "\t\t::tailcall forward $name myclass $name\n"
 "\t}\n"
 "\tdefine Slot {\n"
-"\t\tmethod -appendifnew -export args {\n"
-"\t\t\tset my [namespace which my]\n"
-"\t\t\tset current [uplevel 1 [list $my Get]]\n"
-"\t\t\tforeach a $args {\n"
-"\t\t\t\tset a [uplevel 1 [list $my Resolve $a]]\n"
-"\t\t\t\tif {$a ni $current} {\n"
-"\t\t\t\t\tlappend current $a\n"
-"\t\t\t\t}\n"
-"\t\t\t}\n"
-"\t\t\ttailcall my Set $current\n"
-"\t\t}\n"
-"\t\tmethod -remove -export args {\n"
-"\t\t\tset my [namespace which my]\n"
-"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
-"\t\t\tset current [uplevel 1 [list $my Get]]\n"
-"\t\t\ttailcall my Set [lmap val $current {\n"
-"\t\t\t\tif {$val in $args} continue else {set val}\n"
-"\t\t\t}]\n"
-"\t\t}\n"
 "\t\tforward --default-operation my -append\n"
 "\t\tunexport destroy\n"
 "\t}\n"
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 535c56c..e829fcf 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -198,33 +198,13 @@
     define Slot {
 	# ------------------------------------------------------------------
 	#
-	# Slot -appendifnew, -remove, --default-operation --
+	# Slot --default-operation --
 	#
-	#	Standard public slot operations. If a slot can't figure out
-	#	what method to call directly, it uses --default-operation.
+	#	If a slot can't figure out what method to call directly, it
+	#	uses --default-operation.
 	#
 	# ------------------------------------------------------------------
 
-	method -appendifnew -export args {
-	    set my [namespace which my]
-	    set current [uplevel 1 [list $my Get]]
-	    foreach a $args {
-		set a [uplevel 1 [list $my Resolve $a]]
-		if {$a ni $current} {
-		    lappend current $a
-		}
-	    }
-	    tailcall my Set $current
-	}
-	method -remove -export args {
-	    set my [namespace which my]
-	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
-	    set current [uplevel 1 [list $my Get]]
-	    tailcall my Set [lmap val $current {
-		if {$val in $args} continue else {set val}
-	    }]
-	}
-
 	# Default handling
 	forward --default-operation my -append
 
-- 
cgit v0.12


From e1258546489953eb45a48865c23ad51bbecde367 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 19 Aug 2025 14:46:11 +0000
Subject: Add some documentation comments

---
 generic/tclOODefineCmds.c | 175 +++++++++++++++++++++++++++++++++++++---------
 1 file changed, 142 insertions(+), 33 deletions(-)

diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 0c4d328..199fce7 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -2486,64 +2486,87 @@ TclOODefineSlots(
     return TCL_OK;
 }
 
-static inline int
+/*
+ * ----------------------------------------------------------------------
+ *
+ * CallSlotGet, CallSlotSet, CallSlotResolve, ResolveAll --
+ *
+ *	How to call the standard low-level methods of a slot.
+ *	ResolveAll is the lifting of CallSlotResolve to work over a whole
+ *	list of items.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+// Call [$slot Get] to retrieve the list of contents of the slot
+static inline Tcl_Obj *
 CallSlotGet(
     Tcl_Interp *interp,
-    Object *oPtr)
+    Object *slot)
 {
     Tcl_Obj *getArgs[] = {
-	oPtr->fPtr->myName,
-	oPtr->fPtr->slotGetName
+	slot->fPtr->myName,
+	slot->fPtr->slotGetName
     };
-    return TclOOPrivateObjectCmd(oPtr, interp, 2, getArgs);
+    int code = TclOOPrivateObjectCmd(slot, interp, 2, getArgs);
+    if (code != TCL_OK) {
+	return NULL;
+    }
+    return Tcl_GetObjResult(interp);
 }
 
+// Call [$slot Set $list] to set the list of contents of the slot
 static inline int
 CallSlotSet(
     Tcl_Interp *interp,
-    Object *oPtr,
+    Object *slot,
     Tcl_Obj *list)
 {
     Tcl_Obj *setArgs[] = {
-	oPtr->fPtr->myName,
-	oPtr->fPtr->slotSetName,
+	slot->fPtr->myName,
+	slot->fPtr->slotSetName,
 	list
     };
-    return TclOOPrivateObjectCmd(oPtr, interp, 3, setArgs);
+    return TclOOPrivateObjectCmd(slot, interp, 3, setArgs);
 }
 
-static inline int
+// Call [$slot Resolve $item] to convert a slot item into canonical form
+static inline Tcl_Obj *
 CallSlotResolve(
     Tcl_Interp *interp,
-    Object *oPtr,
+    Object *slot,
     Tcl_Obj *item)
 {
     Tcl_Obj *resolveArgs[] = {
-	oPtr->fPtr->myName,
-	oPtr->fPtr->slotResolveName,
+	slot->fPtr->myName,
+	slot->fPtr->slotResolveName,
 	item
     };
-    return TclOOPrivateObjectCmd(oPtr, interp, 3, resolveArgs);
+    int code = TclOOPrivateObjectCmd(slot, interp, 3, resolveArgs);
+    if (code != TCL_OK) {
+	return NULL;
+    }
+    return Tcl_GetObjResult(interp);
 }
 
 static inline Tcl_Obj *
 ResolveAll(
     Tcl_Interp *interp,
-    Object *oPtr,
+    Object *slot,
     int objc,
     Tcl_Obj *const *objv)
 {
     Tcl_Obj **resolvedItems = (Tcl_Obj **) TclStackAlloc(interp,
 	    sizeof(Tcl_Obj *) * objc);
     for (int i = 0; i < objc; i++) {
-	if (CallSlotResolve(interp, oPtr, objv[i]) != TCL_OK) {
+	resolvedItems[i] = CallSlotResolve(interp, slot, objv[i]);
+	if (resolvedItems[i] == NULL) {
 	    for (int j = 0; j < i; j++) {
 		Tcl_DecrRefCount(resolvedItems[j]);
 	    }
 	    TclStackFree(interp, (void *) resolvedItems);
 	    return NULL;
 	}
-	resolvedItems[i] = Tcl_GetObjResult(interp);
 	Tcl_IncrRefCount(resolvedItems[i]);
 	Tcl_ResetResult(interp);
     }
@@ -2555,6 +2578,15 @@ ResolveAll(
     return resolvedList;
 }
 
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Slot_Append --
+ *
+ *	Implementation of the "-append" slot operation.
+ *
+ * ----------------------------------------------------------------------
+ */
 static int
 Slot_Append(
     TCL_UNUSED(void *),
@@ -2576,11 +2608,11 @@ Slot_Append(
     }
 
     // Get slot contents; store in list
-    if (CallSlotGet(interp, oPtr) != TCL_OK) {
+    Tcl_Obj *list = CallSlotGet(interp, oPtr);
+    if (list == NULL) {
 	Tcl_DecrRefCount(resolved);
 	return TCL_ERROR;
     }
-    Tcl_Obj *list = Tcl_GetObjResult(interp);
     Tcl_IncrRefCount(list);
     Tcl_ResetResult(interp);
 
@@ -2603,7 +2635,16 @@ Slot_Append(
     Tcl_DecrRefCount(list);
     return code;
 }
-
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Slot_AppendNew --
+ *
+ *	Implementation of the "-appendifnew" slot operation.
+ *
+ * ----------------------------------------------------------------------
+ */
 static int
 Slot_AppendNew(
     TCL_UNUSED(void *),
@@ -2625,11 +2666,11 @@ Slot_AppendNew(
     }
 
     // Get slot contents; store in list
-    if (CallSlotGet(interp, oPtr) != TCL_OK) {
+    Tcl_Obj *list = CallSlotGet(interp, oPtr);
+    if (list == NULL) {
 	Tcl_DecrRefCount(resolved);
 	return TCL_ERROR;
     }
-    Tcl_Obj *list = Tcl_GetObjResult(interp);
     Tcl_IncrRefCount(list);
     Tcl_ResetResult(interp);
 
@@ -2670,7 +2711,16 @@ Slot_AppendNew(
     Tcl_DecrRefCount(list);
     return code;
 }
-
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Slot_Clear --
+ *
+ *	Implementation of the "-clear" slot operation.
+ *
+ * ----------------------------------------------------------------------
+ */
 static int
 Slot_Clear(
     TCL_UNUSED(void *),
@@ -2691,7 +2741,16 @@ Slot_Clear(
     Tcl_DecrRefCount(list);
     return code;
 }
-
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Slot_Prepend --
+ *
+ *	Implementation of the "-prepend" slot operation.
+ *
+ * ----------------------------------------------------------------------
+ */
 static int
 Slot_Prepend(
     TCL_UNUSED(void *),
@@ -2714,11 +2773,12 @@ Slot_Prepend(
     Tcl_IncrRefCount(list);
 
     // Get slot contents and append to list
-    if (CallSlotGet(interp, oPtr) != TCL_OK) {
+    Tcl_Obj *oldList = CallSlotGet(interp, oPtr);
+    if (oldList == NULL) {
 	Tcl_DecrRefCount(list);
 	return TCL_ERROR;
     }
-    Tcl_ListObjAppendList(NULL, list, Tcl_GetObjResult(interp));
+    Tcl_ListObjAppendList(NULL, list, oldList);
     Tcl_ResetResult(interp);
 
     // Set slot contents
@@ -2726,7 +2786,16 @@ Slot_Prepend(
     Tcl_DecrRefCount(list);
     return code;
 }
-
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Slot_Remove --
+ *
+ *	Implementation of the "-remove" slot operation.
+ *
+ * ----------------------------------------------------------------------
+ */
 static int
 Slot_Remove(
     TCL_UNUSED(void *),
@@ -2748,11 +2817,11 @@ Slot_Remove(
     }
 
     // Get slot contents; store in list
-    if (CallSlotGet(interp, oPtr) != TCL_OK) {
+    Tcl_Obj *oldList = CallSlotGet(interp, oPtr);
+    if (oldList == NULL) {
 	Tcl_DecrRefCount(resolved);
 	return TCL_ERROR;
     }
-    Tcl_Obj *oldList = Tcl_GetObjResult(interp);
     Tcl_IncrRefCount(oldList);
     Tcl_ResetResult(interp);
 
@@ -2788,7 +2857,17 @@ Slot_Remove(
     Tcl_DecrRefCount(newList);
     return code;
 }
-
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Slot_Resolve --
+ *
+ *	Default implementation of the "Resolve" slot accessor. Just returns
+ *	its argument unchanged; particular slots may override.
+ *
+ * ----------------------------------------------------------------------
+ */
 static int
 Slot_Resolve(
     TCL_UNUSED(void *),
@@ -2805,7 +2884,16 @@ Slot_Resolve(
     Tcl_SetObjResult(interp, objv[objc - 1]);
     return TCL_OK;
 }
-
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Slot_Set --
+ *
+ *	Implementation of the "-set" slot operation.
+ *
+ * ----------------------------------------------------------------------
+ */
 static int
 Slot_Set(
     TCL_UNUSED(void *),
@@ -2834,7 +2922,17 @@ Slot_Set(
     Tcl_DecrRefCount(list);
     return code;
 }
-
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Slot_Unimplemented --
+ *
+ *	Default implementation of the "Get" and "Set" slot accessors. Just
+ *	returns an error; actual slots must override.
+ *
+ * ----------------------------------------------------------------------
+ */
 static int
 Slot_Unimplemented(
     TCL_UNUSED(void *),
@@ -2847,7 +2945,18 @@ Slot_Unimplemented(
     OO_ERROR(interp, ABSTRACT_SLOT);
     return TCL_ERROR;
 }
-
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Slot_Unknown --
+ *
+ *	Unknown method name handler for slots. Delegates to the default slot
+ *	operation (--default-operation forwarded method) unless the first
+ *	argument starts with a dash.
+ *
+ * ----------------------------------------------------------------------
+ */
 static int
 Slot_Unknown(
     TCL_UNUSED(void *),
-- 
cgit v0.12


From 562da42399d8ca6235ac3bc1f49e7048d27bfcb1 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Tue, 19 Aug 2025 15:05:34 +0000
Subject: Experimental simplification for platform on MacOS

---
 library/platform/platform.tcl | 101 +++++++++++-------------------------------
 1 file changed, 26 insertions(+), 75 deletions(-)

diff --git a/library/platform/platform.tcl b/library/platform/platform.tcl
index 3bf1ff6..eb0e1dd 100644
--- a/library/platform/platform.tcl
+++ b/library/platform/platform.tcl
@@ -123,7 +123,12 @@ proc ::platform::generic {} {
 	    }
 	}
 	darwin {
-	    set plat macosx
+	    set major [lindex [split $tcl_platform(osVersion) .] 0]
+	    if {$major > 15} {
+		set plat macos
+	    } else {
+		set plat macosx
+	    }
 	    # Correctly identify the cpu when running as a 64bit
 	    # process on a machine with a 32bit kernel
 	    if {$cpu eq "ix86"} {
@@ -171,26 +176,28 @@ proc ::platform::identify {} {
     set id [generic]
     regexp {^([^-]+)-([^-]+)$} $id -> plat cpu
 
-    switch -- $plat {
+    switch -glob -- $plat {
 	solaris {
 	    regsub {^5} $tcl_platform(osVersion) 2 text
 	    append plat $text
 	    return "${plat}-${cpu}"
 	}
-	macosx {
+	macos* {
 	    set major [lindex [split $tcl_platform(osVersion) .] 0]
-	    if {$major > 19} {
-		set minor [lindex [split $tcl_platform(osVersion) .] 1]
-		incr major 1
+	    incr major 1
+	    if {$major > 22} {
 		if {$major < 26} {
 		    incr major -10
 		}
+		append plat $major
+	    } elif {$major > 20} {
+		set minor [lindex [split $tcl_platform(osVersion) .] 1]
 		if {$major < 14} {
 		    incr minor -1
 		}
 		append plat $major.$minor
 	    } else {
-		incr major -4
+		incr major -5
 		append plat 10.$major
 	    }
 	    return "${plat}-${cpu}"
@@ -343,9 +350,9 @@ proc ::platform::patterns {id} {
 	macosx-ix86 {
 	    lappend res macosx-universal macosx-i386-x86_64
 	}
-	macosx*-*    {
+	macos*-*    {
 	    # 10.5+,11.0+
-	    if {[regexp {macosx([^-]*)-(.*)} $id -> v cpu]} {
+	    if {[regexp {macosx?([^-]*)-(.*)} $id -> v cpu]} {
 
 		switch -exact -- $cpu {
 		    ix86    {
@@ -366,76 +373,20 @@ proc ::platform::patterns {id} {
 		}
 
 		if {$v ne ""} {
-		    foreach {major minor} [split $v .] break
-
+		    foreach {major minor} [split $v.5 .] break
 		    set res {}
-		    if {$major > 26} {
-			# Add x.0 to x.minor to patterns.
-			for {set j $minor} {$j >= 0} {incr j -1} {
-			    lappend res macosx${major}.${j}-${cpu}
-			    foreach a $alt {
-				lappend res macosx${major}.${j}-$a
-			    }
+		    while {$major > 11} {
+			# Add $major to patterns.
+			lappend res macos${major}-${cpu}
+			foreach a $alt {
+			    lappend res macos${major}-$a
 			}
 			incr major -1
-			set minor 5; # Assume that (major-1).5 will be there one day. 
-		    }
-		    if {$major eq 26} {
-			# Add 26.0 to 26.minor to patterns.
-			for {set j $minor} {$j >= 0} {incr j -1} {
-			    lappend res macosx${major}.${j}-${cpu}
-			    foreach a $alt {
-				lappend res macosx${major}.${j}-$a
-			    }
-			}
-			set major 15
-			set minor 6
-		    }
-		    if {$major eq 15} {
-			# Add 15.0 to 15.minor to patterns.
-			for {set j $minor} {$j >= 0} {incr j -1} {
-			    lappend res macosx${major}.${j}-${cpu}
-			    foreach a $alt {
-				lappend res macosx${major}.${j}-$a
-			    }
-			}
-			set major 14
-			set minor 6
-		    }
-		    if {$major eq 14} {
-			# Add 14.0 to 14.minor to patterns.
-			for {set j $minor} {$j >= 0} {incr j -1} {
-			    lappend res macosx${major}.${j}-${cpu}
-			    foreach a $alt {
-				lappend res macosx${major}.${j}-$a
-			    }
-			}
-			set major 13
-			set minor 5
-		    }
-		    if {$major eq 13} {
-			# Add 13.0 to 13.minor to patterns.
-			for {set j $minor} {$j >= 0} {incr j -1} {
-			    lappend res macosx${major}.${j}-${cpu}
-			    foreach a $alt {
-				lappend res macosx${major}.${j}-$a
-			    }
-			}
-			set major 12
-			set minor 5
-		    }
-		    if {$major eq 12} {
-			# Add 12.0 to 12.minor to patterns.
-			for {set j $minor} {$j >= 0} {incr j -1} {
-			    lappend res macosx${major}.${j}-${cpu}
-			    foreach a $alt {
-				lappend res macosx${major}.${j}-$a
-			    }
+			if {$major == 25} {
+			    set major 15
 			}
-			set major 11
-			set minor 5
 		    }
-		    if {$major eq 11} {
+		    if {$major == 11} {
 			# Add 11.0 to 11.minor to patterns.
 			for {set j $minor} {$j >= 0} {incr j -1} {
 			    lappend res macosx${major}.${j}-${cpu}
@@ -465,7 +416,7 @@ proc ::platform::patterns {id} {
 				lappend res macosx${major}.${j}-$a
 			    }
 			}
-    			# Add unversioned patterns for 10.3/10.4 builds.
+			# Add unversioned patterns for 10.3/10.4 builds.
 			lappend res macosx-${cpu}
 			foreach a $alt {
 			    lappend res macosx-$a
-- 
cgit v0.12


From c418b4db02db0cf5df8fafb6d52dddfb4f299ef2 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 19 Aug 2025 15:45:53 +0000
Subject: Slightly faster way to write the init script

---
 generic/tclOOScript.h | 59 +++++++++++++++++-------------------
 tools/tclOOScript.tcl | 84 +++++++++++++++++++++++----------------------------
 2 files changed, 65 insertions(+), 78 deletions(-)

diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 80c4c68..6b0c5bd 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -116,10 +116,8 @@ static const char *tclOOSetupScript =
 "\t\t}\n"
 "\t\t::tailcall forward $name myclass $name\n"
 "\t}\n"
-"\tdefine Slot {\n"
-"\t\tforward --default-operation my -append\n"
-"\t\tunexport destroy\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"
 "\tobjdefine define::mixin forward --default-operation my -set\n"
 "\tobjdefine objdefine::mixin forward --default-operation my -set\n"
@@ -154,31 +152,29 @@ static const char *tclOOSetupScript =
 "\t\tnext $originObject\n"
 "\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
 "\t}\n"
-"\tclass create singleton {\n"
-"\t\tsuperclass -set class\n"
-"\t\tvariable -set object\n"
-"\t\tunexport create createWithNamespace\n"
-"\t\tmethod new args {\n"
-"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n"
-"\t\t\t\tset object [next {*}$args]\n"
-"\t\t\t\t::oo::objdefine $object {\n"
-"\t\t\t\t\tmethod destroy {} {\n"
-"\t\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n"
-"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n"
-"\t\t\t\t\t}\n"
-"\t\t\t\t\tmethod <cloned> -unexport {originObject} {\n"
-"\t\t\t\t\t\t::return -code error -errorcode {TCL OO SINGLETON} \\\n"
-"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n"
-"\t\t\t\t\t}\n"
+"\tclass create singleton\n"
+"\tdefine singleton superclass -set class\n"
+"\tdefine singleton variable -set object\n"
+"\tdefine singleton unexport create createWithNamespace\n"
+"\tdefine singleton method new args {\n"
+"\t\tif {![info exists object] || ![info object isa object $object]} {\n"
+"\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\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\t\t\"may not clone a singleton object\"\n"
 "\t\t\t\t}\n"
 "\t\t\t}\n"
-"\t\t\treturn $object\n"
 "\t\t}\n"
+"\t\treturn $object\n"
 "\t}\n"
-"\tclass create abstract {\n"
-"\t\tsuperclass -set class\n"
-"\t\tunexport create createWithNamespace new\n"
-"\t}\n"
+"\tclass create abstract\n"
+"\tdefine abstract superclass -set class\n"
+"\tdefine abstract unexport create createWithNamespace new\n"
 "\tnamespace eval configuresupport::configurableclass {\n"
 "\t\t::proc properties args {::tailcall property {*}$args}\n"
 "\t\t::namespace path ::oo::define\n"
@@ -193,14 +189,13 @@ static const char *tclOOSetupScript =
 "\t\tdefinitionnamespace -instance configuresupport::configurableobject\n"
 "\t\tdefinitionnamespace -class configuresupport::configurableclass\n"
 "\t}\n"
-"\tclass create configurable {\n"
-"\t\tsuperclass -set class\n"
-"\t\tconstructor {{definitionScript \"\"}} {\n"
-"\t\t\tnext {mixin ::oo::configuresupport::configurable}\n"
-"\t\t\tnext $definitionScript\n"
-"\t\t}\n"
-"\t\tdefinitionnamespace -class configuresupport::configurableclass\n"
+"\tclass create configurable\n"
+"\tdefine configurable superclass -set class\n"
+"\tdefine configurable constructor {{definitionScript \"\"}} {\n"
+"\t\tnext {mixin ::oo::configuresupport::configurable}\n"
+"\t\tnext $definitionScript\n"
 "\t}\n"
+"\tdefine configurable definitionnamespace -class configuresupport::configurableclass\n"
 "}\n"
 /* !END!: Do not edit above this line. */
 ;
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index e829fcf..2b9e2a4 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -195,22 +195,18 @@
     #
     # ----------------------------------------------------------------------
 
-    define Slot {
-	# ------------------------------------------------------------------
-	#
-	# Slot --default-operation --
-	#
-	#	If a slot can't figure out what method to call directly, it
-	#	uses --default-operation.
-	#
-	# ------------------------------------------------------------------
-
-	# Default handling
-	forward --default-operation my -append
-
-	# Hide destroy
-	unexport destroy
-    }
+    # ------------------------------------------------------------------
+    #
+    # Slot --default-operation --
+    #
+    #	If a slot can't figure out what method to call directly, it
+    #	uses --default-operation.
+    #
+    # ------------------------------------------------------------------
+    define Slot forward --default-operation my -append
+
+    # Hide destroy
+    define Slot unexport destroy
 
     # Set the default operation differently for these slots
     objdefine define::superclass forward --default-operation my -set
@@ -283,26 +279,25 @@
     #
     # ----------------------------------------------------------------------
 
-    class create singleton {
-	superclass -set class
-	variable -set object
-	unexport create createWithNamespace
-	method new args {
-	    if {![info exists object] || ![info object isa object $object]} {
-		set object [next {*}$args]
-		::oo::objdefine $object {
-		    method destroy {} {
-			::return -code error -errorcode {TCL OO SINGLETON} \
-			    "may not destroy a singleton object"
-		    }
-		    method <cloned> -unexport {originObject} {
-			::return -code error -errorcode {TCL OO SINGLETON} \
-			    "may not clone a singleton object"
-		    }
+    class create singleton
+    define singleton superclass -set class
+    define singleton variable -set object
+    define singleton unexport create createWithNamespace
+    define singleton method new args {
+	if {![info exists object] || ![info object isa object $object]} {
+	    set object [next {*}$args]
+	    ::oo::objdefine $object {
+		method destroy {} {
+		    ::return -code error -errorcode {TCL OO SINGLETON} \
+			"may not destroy a singleton object"
+		}
+		method <cloned> -unexport {originObject} {
+		    ::return -code error -errorcode {TCL OO SINGLETON} \
+			"may not clone a singleton object"
 		}
 	    }
-	    return $object
 	}
+	return $object
     }
 
     # ----------------------------------------------------------------------
@@ -314,10 +309,9 @@
     #
     # ----------------------------------------------------------------------
 
-    class create abstract {
-	superclass -set class
-	unexport create createWithNamespace new
-    }
+    class create abstract
+    define abstract superclass -set class
+    define abstract unexport create createWithNamespace new
 
     # ----------------------------------------------------------------------
     #
@@ -397,16 +391,14 @@
     #
     # ----------------------------------------------------------------------
 
-    class create configurable {
-	superclass -set class
-
-	constructor {{definitionScript ""}} {
-	    next {mixin ::oo::configuresupport::configurable}
-	    next $definitionScript
-	}
-
-	definitionnamespace -class configuresupport::configurableclass
+    class create configurable
+    define configurable superclass -set class
+    define configurable constructor {{definitionScript ""}} {
+	next {mixin ::oo::configuresupport::configurable}
+	next $definitionScript
     }
+
+    define configurable definitionnamespace -class configuresupport::configurableclass
 }
 
 # Local Variables:
-- 
cgit v0.12


From c7706471adbd05bf2150297c58e47b27dc2d5be7 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Tue, 19 Aug 2025 21:48:16 +0000
Subject: Bug-fixing

---
 library/platform/platform.tcl | 21 +++++----------------
 1 file changed, 5 insertions(+), 16 deletions(-)

diff --git a/library/platform/platform.tcl b/library/platform/platform.tcl
index eb0e1dd..9bbc7be 100644
--- a/library/platform/platform.tcl
+++ b/library/platform/platform.tcl
@@ -184,13 +184,13 @@ proc ::platform::identify {} {
 	}
 	macos* {
 	    set major [lindex [split $tcl_platform(osVersion) .] 0]
-	    incr major 1
-	    if {$major > 22} {
+	    incr major
+	    if {$major > 21} {
 		if {$major < 26} {
 		    incr major -10
 		}
 		append plat $major
-	    } elif {$major > 20} {
+	    } elseif {$major > 20} {
 		set minor [lindex [split $tcl_platform(osVersion) .] 1]
 		if {$major < 14} {
 		    incr minor -1
@@ -373,9 +373,9 @@ proc ::platform::patterns {id} {
 		}
 
 		if {$v ne ""} {
-		    foreach {major minor} [split $v.5 .] break
+		    foreach {major minor} [split $v.15 .] break
 		    set res {}
-		    while {$major > 11} {
+		    while {$major > 10} {
 			# Add $major to patterns.
 			lappend res macos${major}-${cpu}
 			foreach a $alt {
@@ -386,17 +386,6 @@ proc ::platform::patterns {id} {
 			    set major 15
 			}
 		    }
-		    if {$major == 11} {
-			# Add 11.0 to 11.minor to patterns.
-			for {set j $minor} {$j >= 0} {incr j -1} {
-			    lappend res macosx${major}.${j}-${cpu}
-			    foreach a $alt {
-				lappend res macosx${major}.${j}-$a
-			    }
-			}
-			set major 10
-			set minor 15
-		    }
 		    # Add 10.9 to 10.minor to patterns.
 		    for {set j $minor} {$j >= 9} {incr j -1} {
 			if {$cpu ne "arm"} {
-- 
cgit v0.12


From 10f3bcbb8d0434693a3cf99c50ccbcd5be80e484 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 20 Aug 2025 10:11:04 +0000
Subject: Move another command into C: classvariable

---
 generic/tclOO.c       |  2 ++
 generic/tclOOBasic.c  | 91 +++++++++++++++++++++++++++++++++++++++++++++++++++
 generic/tclOOInt.h    |  1 +
 generic/tclOOScript.h | 17 ----------
 tools/tclOOScript.tcl | 29 ----------------
 5 files changed, 94 insertions(+), 46 deletions(-)

diff --git a/generic/tclOO.c b/generic/tclOO.c
index 1e8012f..4a2e35c 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -444,6 +444,8 @@ InitFoundation(
 	    TclOOCallbackObjCmd, NULL, NULL, 0);
     CreateCmdInNS(interp, fPtr->helpersNs, "mymethod",
 	    TclOOCallbackObjCmd, NULL, NULL, 0);
+    CreateCmdInNS(interp, fPtr->helpersNs, "classvariable",
+	    TclOOClassVariableObjCmd, NULL, NULL, 0);
     CreateCmdInNS(interp, fPtr->helpersNs, "next",
 	    NULL, TclOONextObjCmd, TclCompileObjectNextCmd, CMD_COMPILES_EXPANDED);
     CreateCmdInNS(interp, fPtr->helpersNs, "nextto",
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index aefa91d..866f080 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -1412,6 +1412,97 @@ TclOOCallbackObjCmd(
 }
 
 /*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOClassVariableObjCmd --
+ *
+ *	Implementation of the [classvariable] command, which links to
+ *	variables in the class of the current object.
+ *
+ * ----------------------------------------------------------------------
+ */
+int
+TclOOClassVariableObjCmd(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Interp *iPtr = (Interp *) interp;
+    CallFrame *framePtr = iPtr->varFramePtr;
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "name ...");
+	return TCL_ERROR;
+    }
+
+    /*
+     * Start with sanity checks on the calling context to make sure that we
+     * are invoked from a suitable method context. If so, we can safely
+     * retrieve the handle to the object call context.
+     */
+
+    if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"%s may only be called from inside a method",
+		TclGetString(objv[0])));
+	OO_ERROR(interp, CONTEXT_REQUIRED);
+	return TCL_ERROR;
+    }
+
+    // Get a reference to the class's namespace
+    CallContext *contextPtr = (CallContext *) framePtr->clientData;
+    Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;
+    if (clsPtr == NULL) {
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		"method not defined by a class", TCL_AUTO_LENGTH));
+	OO_ERROR(interp, UNMATCHED_CONTEXT);
+	return TCL_ERROR;
+    }
+    Tcl_Namespace *clsNsPtr = clsPtr->thisPtr->namespacePtr;
+
+    // Check the list of variable names
+    for (int i = 1; i < objc; i++) {
+	const char *varName = TclGetString(objv[i]);
+	if (Tcl_StringMatch(varName, "*(*)")) {
+	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		    "bad variable name \"%s\": can't create a %s",
+		    varName, "scalar variable that looks like an array element"));
+	    Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL);
+	    return TCL_ERROR;
+	}
+	if (Tcl_StringMatch(varName, "*::*")) {
+	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		    "bad variable name \"%s\": can't create a %s",
+		    varName, "local variable with a namespace separator in it"));
+	    Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL);
+	    return TCL_ERROR;
+	}
+    }
+
+    // Lastly, link the caller's local variables to the class's variables
+    Tcl_Namespace *ourNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
+    for (int i = 1; i < objc; i++) {
+	// Locate the other variable.
+	iPtr->varFramePtr->nsPtr = (Namespace *) clsNsPtr;
+	Var *arrayPtr, *otherPtr = TclObjLookupVarEx(interp, objv[i], NULL,
+		(TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS),
+		"access", /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
+	iPtr->varFramePtr->nsPtr = (Namespace *) ourNsPtr;
+	if (otherPtr == NULL) {
+	    return TCL_ERROR;
+	}
+
+	// Create the new variable and link it to otherPtr.
+	if (TclPtrObjMakeUpvarIdx(interp, otherPtr, objv[i], 0, -1) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+    }
+
+    return TCL_OK;
+}
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 94eda61..0367e60 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -519,6 +519,7 @@ MODULE_SCOPE Tcl_ObjCmdProc	TclOODefinePrivateObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOODefinePropertyCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOUnknownDefinition;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOCallbackObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc	TclOOClassVariableObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOCopyObjectCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOONextObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOONextToObjCmd;
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 6b0c5bd..dcc44c0 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -27,23 +27,6 @@
 static const char *tclOOSetupScript =
 /* !BEGIN!: Do not edit below this line. */
 "::namespace eval ::oo {\n"
-"\tproc Helpers::classvariable {name args} {\n"
-"\t\tset ns [info object namespace [uplevel 1 {self class}]]\n"
-"\t\tforeach v [list $name {*}$args] {\n"
-"\t\t\tif {[string match *(*) $v]} {\n"
-"\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n"
-"\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n"
-"\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
-"\t\t\t}\n"
-"\t\t\tif {[string match *::* $v]} {\n"
-"\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n"
-"\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n"
-"\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
-"\t\t\t}\n"
-"\t\t\tlappend vs $v $v\n"
-"\t\t}\n"
-"\t\ttailcall namespace upvar $ns {*}$vs\n"
-"\t}\n"
 "\tproc Helpers::link {args} {\n"
 "\t\tset ns [uplevel 1 {::namespace current}]\n"
 "\t\tforeach link $args {\n"
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 2b9e2a4..3f34c56 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -19,35 +19,6 @@
 
     # ------------------------------------------------------------------
     #
-    # classvariable --
-    #
-    #	Link to a variable in the class of the current object.
-    #
-    # ------------------------------------------------------------------
-
-    proc Helpers::classvariable {name args} {
-	# Get a reference to the class's namespace
-	set ns [info object namespace [uplevel 1 {self class}]]
-	# Double up the list of variable names
-	foreach v [list $name {*}$args] {
-	    if {[string match *(*) $v]} {
-		set reason "can't create a scalar variable that looks like an array element"
-		return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \
-		    [format {bad variable name "%s": %s} $v $reason]
-	    }
-	    if {[string match *::* $v]} {
-		set reason "can't create a local variable with a namespace separator in it"
-		return -code error -errorcode {TCL UPVAR INVERTED} \
-		    [format {bad variable name "%s": %s} $v $reason]
-	    }
-	    lappend vs $v $v
-	}
-	# Lastly, link the caller's local variables to the class's variables
-	tailcall namespace upvar $ns {*}$vs
-    }
-
-    # ------------------------------------------------------------------
-    #
     # link --
     #
     #	Make a command that invokes a method on the current object.
-- 
cgit v0.12


From f80e08da71e969b6b79dd861d91f684a8159e9f2 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 20 Aug 2025 12:22:28 +0000
Subject: Move a bit of internal machinery

---
 generic/tclOO.c       |  1 +
 generic/tclOOBasic.c  | 37 ++++++++++++++++++++++++++++++++++++-
 generic/tclOOInt.h    |  1 +
 generic/tclOOScript.h |  3 ---
 tools/tclOOScript.tcl | 14 --------------
 5 files changed, 38 insertions(+), 18 deletions(-)

diff --git a/generic/tclOO.c b/generic/tclOO.c
index 4a2e35c..ec20537 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -456,6 +456,7 @@ InitFoundation(
     CreateCmdInNS(interp, fPtr->ooNs, "define", TclOODefineObjCmd, NULL, NULL, 0);
     CreateCmdInNS(interp, fPtr->ooNs, "objdefine", TclOOObjDefObjCmd, NULL, NULL, 0);
     CreateCmdInNS(interp, fPtr->ooNs, "copy", TclOOCopyObjectCmd, NULL, NULL, 0);
+    CreateCmdInNS(interp, fPtr->ooNs, "DelegateName", TclOODelegateNameObjCmd, NULL, NULL, 0);
 
     TclOOInitInfo(interp);
 
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 866f080..44d8cb6 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -1494,7 +1494,8 @@ TclOOClassVariableObjCmd(
 	}
 
 	// Create the new variable and link it to otherPtr.
-	if (TclPtrObjMakeUpvarIdx(interp, otherPtr, objv[i], 0, -1) != TCL_OK) {
+	if (TclPtrObjMakeUpvarIdx(interp, otherPtr, objv[i], 0,
+		TCL_INDEX_NONE) != TCL_OK) {
 	    return TCL_ERROR;
 	}
     }
@@ -1503,6 +1504,40 @@ TclOOClassVariableObjCmd(
 }
 
 /*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODelegateNameObjCmd --
+ *
+ *	Implementation of the [oo::DelegateName] command, which is a utility
+ *	that gets the name of the class delegate for a class. It's trivial,
+ *	but makes working with them much easier as delegate names are
+ *	intentionally hard to create by accident.
+ *
+ *	Not part of TclOO public API. No public documentation.
+ *
+ * ----------------------------------------------------------------------
+ */
+int
+TclOODelegateNameObjCmd(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "class");
+	return TCL_ERROR;
+    }
+    Class *clsPtr = TclOOGetClassFromObj(interp, objv[1]);
+    if (clsPtr == NULL) {
+	return TCL_ERROR;
+    }
+    Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s:: oo ::delegate",
+	    clsPtr->thisPtr->namespacePtr->fullName));
+    return TCL_OK;
+}
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 0367e60..1331703 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -521,6 +521,7 @@ MODULE_SCOPE Tcl_ObjCmdProc	TclOOUnknownDefinition;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOCallbackObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOClassVariableObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOCopyObjectCmd;
+MODULE_SCOPE Tcl_ObjCmdProc	TclOODelegateNameObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOONextObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOONextToObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOSelfObjCmd;
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index dcc44c0..643e536 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -52,9 +52,6 @@ static const char *tclOOSetupScript =
 "\t\t\trename $cmd {}\n"
 "\t\t}\n"
 "\t}\n"
-"\tproc DelegateName {class} {\n"
-"\t\tstring cat [info object namespace $class] {:: oo ::delegate}\n"
-"\t}\n"
 "\tproc MixinClassDelegates {class} {\n"
 "\t\tif {![info object isa class $class]} {\n"
 "\t\t\treturn\n"
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 3f34c56..2cf40e1 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -65,20 +65,6 @@
 
     # ----------------------------------------------------------------------
     #
-    # DelegateName --
-    #
-    #	Utility that gets the name of the class delegate for a class. It's
-    #	trivial, but makes working with them much easier as delegate names are
-    #	intentionally hard to create by accident.
-    #
-    # ----------------------------------------------------------------------
-
-    proc DelegateName {class} {
-	string cat [info object namespace $class] {:: oo ::delegate}
-    }
-
-    # ----------------------------------------------------------------------
-    #
     # MixinClassDelegates --
     #
     #	Support code called *after* [oo::define] inside the constructor of a
-- 
cgit v0.12


From 17a2efee72c4624cd964a07d8e18dca02c985f20 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Wed, 20 Aug 2025 21:53:34 +0000
Subject: Keep all macos < 11 handling as it was

---
 library/platform/platform.tcl | 14 ++++----------
 1 file changed, 4 insertions(+), 10 deletions(-)

diff --git a/library/platform/platform.tcl b/library/platform/platform.tcl
index 9bbc7be..d188a5e 100644
--- a/library/platform/platform.tcl
+++ b/library/platform/platform.tcl
@@ -124,7 +124,7 @@ proc ::platform::generic {} {
 	}
 	darwin {
 	    set major [lindex [split $tcl_platform(osVersion) .] 0]
-	    if {$major > 15} {
+	    if {$major > 19} {
 		set plat macos
 	    } else {
 		set plat macosx
@@ -184,20 +184,14 @@ proc ::platform::identify {} {
 	}
 	macos* {
 	    set major [lindex [split $tcl_platform(osVersion) .] 0]
-	    incr major
-	    if {$major > 21} {
+	    if {$major > 19} {
+		incr major
 		if {$major < 26} {
 		    incr major -10
 		}
 		append plat $major
-	    } elseif {$major > 20} {
-		set minor [lindex [split $tcl_platform(osVersion) .] 1]
-		if {$major < 14} {
-		    incr minor -1
-		}
-		append plat $major.$minor
 	    } else {
-		incr major -5
+		incr major -4
 		append plat 10.$major
 	    }
 	    return "${plat}-${cpu}"
-- 
cgit v0.12


From 905f8b73d720bf9b2bff9c36d225236cf7735778 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Thu, 21 Aug 2025 14:00:13 +0000
Subject: Add testcases

---
 tests/platform.test | 29 ++++++++++++++++++++++++++++-
 1 file changed, 28 insertions(+), 1 deletion(-)

diff --git a/tests/platform.test b/tests/platform.test
index 33aea3a..e11b72d 100644
--- a/tests/platform.test
+++ b/tests/platform.test
@@ -34,7 +34,6 @@ test platform-1.0 {tcl_platform(engine)} {
 test platform-1.1 {TclpSetVariables: tcl_platform} {
     interp create i
     i eval {catch {unset tcl_platform(debug)}}
-    i eval {catch {unset tcl_platform(threaded)}}
     set result [i eval {lsort [array names tcl_platform]}]
     interp delete i
     set result
@@ -72,6 +71,34 @@ test platform-4.2 {format of platform::generic result} -match regexp -body {
     platform::generic
 } -result {^([^-]+-)+[^-]+$}
 
+test platform-5.0 {format of platform::generic result} -setup {
+    set old_machine $::tcl_platform(machine)
+    set old_os $::tcl_platform(os)
+    set old_wordsize $::tcl_platform(wordSize)
+    set old_version $tcl_platform(osVersion)
+    set ::tcl_platform(machine) arm
+    set ::tcl_platform(os) Darwin
+    set ::tcl_platform(wordSize) 8
+} -body {
+    set res {}
+    set l {macosx10.15-x86_64 macosx10.14-x86_64 macosx10.13-x86_64 macosx10.12-x86_64 macosx10.11-x86_64 macosx10.10-x86_64 macosx10.9-x86_64 tcl}
+    foreach v {20.0 21.0 22.0 23.0 24.0 25.0 26.0} {
+	set ::tcl_platform(osVersion) $v
+	set id [platform::identify]
+	set l [linsert $l 0 [string range $id 0 end-4]-x86_64]
+	set l [linsert $l 0 $id]
+	lappend res $id
+	lappend res [expr {($l eq [platform::patterns $id]) ? 1 : [platform::patterns $id]}]
+    }
+    set res
+} -cleanup {
+    set ::tcl_platform(machine) $old_machine
+    set ::tcl_platform(os) $old_os
+    set ::tcl_platform(wordSize) $old_wordsize
+    set ::tcl_platform(osVersion) $old_version
+    unset res l old_machine old_os old_wordsize old_version
+} -result {macos11-arm 1 macos12-arm 1 macos13-arm 1 macos14-arm 1 macos15-arm 1 macos26-arm 1 macos27-arm 1}
+
 # cleanup
 cleanupTests
 
-- 
cgit v0.12


From 4ee7135c5a85552878d7f4f21786d0b17d5bad77 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Thu, 21 Aug 2025 14:15:40 +0000
Subject: Line no longer needed

---
 tests/platform.test | 1 -
 1 file changed, 1 deletion(-)

diff --git a/tests/platform.test b/tests/platform.test
index e11b72d..1b49b40 100644
--- a/tests/platform.test
+++ b/tests/platform.test
@@ -33,7 +33,6 @@ test platform-1.0 {tcl_platform(engine)} {
 
 test platform-1.1 {TclpSetVariables: tcl_platform} {
     interp create i
-    i eval {catch {unset tcl_platform(debug)}}
     set result [i eval {lsort [array names tcl_platform]}]
     interp delete i
     set result
-- 
cgit v0.12


From 03dd129a16f43ca26c64bce498157abd7e249856 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 22 Aug 2025 07:16:45 +0000
Subject: Fix memory debugging info

---
 generic/tclStringObj.c | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 13fbdbc..c33860d 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -235,6 +235,10 @@ Tcl_NewStringObj(
 {
     return Tcl_DbNewStringObj(bytes, length, "unknown", 0);
 }
+
+// Redefine the macro
+#define Tcl_NewStringObj(bytes, len) \
+     Tcl_DbNewStringObj(bytes, len, __FILE__, __LINE__)
 #else /* if not TCL_MEM_DEBUG */
 Tcl_Obj *
 Tcl_NewStringObj(
-- 
cgit v0.12


From 03c0cbaafda3c182f3c71aea9ce223b68273695f Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 22 Aug 2025 07:19:52 +0000
Subject: Convert MixinClassDelegates to an internal function entirely in C

---
 generic/tclOO.c       |   3 -
 generic/tclOOBasic.c  | 158 ++++++++++++++++++++++++++++++++++++++++++--------
 generic/tclOOInt.h    |   2 -
 generic/tclOOScript.h |  17 ------
 tools/tclOOScript.tcl |  27 ---------
 5 files changed, 134 insertions(+), 73 deletions(-)

diff --git a/generic/tclOO.c b/generic/tclOO.c
index ec20537..0ef69a4 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -370,7 +370,6 @@ InitFoundation(
     TclNewLiteralStringObj(fPtr->clonedName, "<cloned>");
     TclNewLiteralStringObj(fPtr->defineName, "::oo::define");
     TclNewLiteralStringObj(fPtr->myName, "my");
-    TclNewLiteralStringObj(fPtr->mcdName, "::oo::MixinClassDelegates");
     TclNewLiteralStringObj(fPtr->slotGetName, "Get");
     TclNewLiteralStringObj(fPtr->slotSetName, "Set");
     TclNewLiteralStringObj(fPtr->slotResolveName, "Resolve");
@@ -381,7 +380,6 @@ InitFoundation(
     Tcl_IncrRefCount(fPtr->clonedName);
     Tcl_IncrRefCount(fPtr->defineName);
     Tcl_IncrRefCount(fPtr->myName);
-    Tcl_IncrRefCount(fPtr->mcdName);
     Tcl_IncrRefCount(fPtr->slotGetName);
     Tcl_IncrRefCount(fPtr->slotSetName);
     Tcl_IncrRefCount(fPtr->slotResolveName);
@@ -631,7 +629,6 @@ KillFoundation(
     TclDecrRefCount(fPtr->clonedName);
     TclDecrRefCount(fPtr->defineName);
     TclDecrRefCount(fPtr->myName);
-    TclDecrRefCount(fPtr->mcdName);
     TclDecrRefCount(fPtr->slotGetName);
     TclDecrRefCount(fPtr->slotSetName);
     TclDecrRefCount(fPtr->slotResolveName);
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 44d8cb6..18dd5e9 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -19,7 +19,7 @@
 
 static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp);
 static Tcl_NRPostProc	AfterNRDestructor;
-static Tcl_NRPostProc	DecrRefsPostClassConstructor;
+static Tcl_NRPostProc	PostClassConstructor;
 static Tcl_NRPostProc	FinalizeConstruction;
 static Tcl_NRPostProc	FinalizeEval;
 static Tcl_NRPostProc	NextRestoreFrame;
@@ -68,6 +68,119 @@ FinalizeConstruction(
 /*
  * ----------------------------------------------------------------------
  *
+ * MixinClassDelegates --
+ *
+ *	Internal utility for setting up the class delegate.
+ *	Runs after the class has called [oo::define] on its argument.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+// Look up the delegate for a class.
+static inline Class *
+GetClassDelegate(
+    Tcl_Interp *interp,
+    Class *clsPtr)
+{
+    Tcl_Obj *delegateName = Tcl_ObjPrintf("%s:: oo ::delegate",
+	    clsPtr->thisPtr->namespacePtr->fullName);
+    Class *delegatePtr = TclOOGetClassFromObj(interp, delegateName);
+    Tcl_DecrRefCount(delegateName);
+    return delegatePtr;
+}
+
+/*
+ * Patches in the appropriate class delegates' superclasses.
+ * Sonewhat nessy because the list of superclasses isn't modified frequently.
+ */
+static inline void
+SetDelegateSuperclasses(
+    Tcl_Interp *interp,
+    Class *clsPtr,
+    Class *delegatePtr)
+{
+    // Build new list of superclasses
+    int i, j = delegatePtr->superclasses.num, k;
+    Class *superPtr, **supers = (Class **) Tcl_Alloc(sizeof(Class *) *
+	    (delegatePtr->superclasses.num + clsPtr->superclasses.num));
+    if (delegatePtr->superclasses.num) {
+	memcpy(supers, delegatePtr->superclasses.list,
+		sizeof(Class *) * delegatePtr->superclasses.num);
+    }
+    FOREACH(superPtr, clsPtr->superclasses) {
+	Class *superDelegatePtr = GetClassDelegate(interp, superPtr);
+	if (!superDelegatePtr) {
+	    continue;
+	}
+	for (k=0 ; k<=j ; k++) {
+	    if (k == j) {
+		supers[j++] = superDelegatePtr;
+		TclOOAddToSubclasses(delegatePtr, superDelegatePtr);
+		AddRef(superDelegatePtr->thisPtr);
+		break;
+	    } else if (supers[k] == superDelegatePtr) {
+		break;
+	    }
+	}
+    }
+
+    // Install new list of superclasses;
+    if (delegatePtr->superclasses.num) {
+	Tcl_Free(delegatePtr->superclasses.list);
+    }
+    delegatePtr->superclasses.list = supers;
+    delegatePtr->superclasses.num = j;
+
+    // Definitely don't need to bump any epoch here
+}
+
+/*
+ * Mixes the delegate into its controlling class.
+ */
+static inline void
+InstallDelegateAsMixin(
+    Tcl_Interp *interp,
+    Class *clsPtr,
+    Class *delegatePtr)
+{
+    if (clsPtr->thisPtr->mixins.num == 0) {
+	TclOOObjectSetMixins(clsPtr->thisPtr, 1, &delegatePtr);
+	return;
+    }
+    Class **mixins = (Class **) TclStackAlloc(interp,
+	    sizeof(Class *) * (clsPtr->thisPtr->mixins.num + 1));
+    for (int i = 0; i < clsPtr->thisPtr->mixins.num; i++) {
+	mixins[i] = clsPtr->thisPtr->mixins.list[i];
+	if (mixins[i] == delegatePtr) {
+	    TclStackFree(interp, (void *) mixins);
+	    return;
+	}
+    }
+    mixins[clsPtr->thisPtr->mixins.num] = delegatePtr;
+    TclOOObjectSetMixins(clsPtr->thisPtr, clsPtr->thisPtr->mixins.num + 1, mixins);
+    TclStackFree(interp, mixins);
+}
+
+// Patches in the appropriate class delegates.
+static void
+MixinClassDelegates(
+    Tcl_Interp *interp,
+    Object *oPtr,
+    Tcl_Obj *delegateName)
+{
+    Class *clsPtr = oPtr->classPtr;
+    if (clsPtr) {
+	Class *delegatePtr = TclOOGetClassFromObj(interp, delegateName);
+	if (delegatePtr) {
+	    SetDelegateSuperclasses(interp, clsPtr, delegatePtr);
+	    InstallDelegateAsMixin(interp, clsPtr, delegatePtr);
+	}
+    }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * TclOO_Class_Constructor --
  *
  *	Implementation for oo::class constructor.
@@ -84,7 +197,6 @@ TclOO_Class_Constructor(
     Tcl_Obj *const *objv)
 {
     Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
-    Tcl_Obj **invoke, *nameObj;
 
     size_t skip = Tcl_ObjectContextSkippedArgs(context);
     if ((size_t) objc > skip + 1) {
@@ -101,25 +213,28 @@ TclOO_Class_Constructor(
      * argument to [oo::define]. [Bug 680503]
      */
 
-    nameObj = Tcl_ObjPrintf("%s:: oo ::delegate",
+    Tcl_Obj *delegateName = Tcl_ObjPrintf("%s:: oo ::delegate",
 	    oPtr->namespacePtr->fullName);
+    Tcl_IncrRefCount(delegateName);
     Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls,
-	    TclGetString(nameObj), NULL, TCL_INDEX_NONE, NULL, 0);
-    Tcl_BounceRefCount(nameObj);
+	    TclGetString(delegateName), NULL, TCL_INDEX_NONE, NULL, 0);
 
     /*
      * If there's nothing else to do, we're done.
      */
 
     if ((size_t) objc == skip) {
-	return TCL_OK;
+	Tcl_InterpState saved = Tcl_SaveInterpState(interp, TCL_OK);
+	MixinClassDelegates(interp, oPtr, delegateName);
+	Tcl_DecrRefCount(delegateName);
+	return Tcl_RestoreInterpState(interp, saved);
     }
 
     /*
      * Delegate to [oo::define] to do the work.
      */
 
-    invoke = (Tcl_Obj **) TclStackAlloc(interp, 3 * sizeof(Tcl_Obj *));
+    Tcl_Obj **invoke = (Tcl_Obj **) TclStackAlloc(interp, 3 * sizeof(Tcl_Obj *));
     invoke[0] = oPtr->fPtr->defineName;
     invoke[1] = TclOOObjectName(interp, oPtr);
     invoke[2] = objv[objc - 1];
@@ -132,8 +247,8 @@ TclOO_Class_Constructor(
     Tcl_IncrRefCount(invoke[0]);
     Tcl_IncrRefCount(invoke[1]);
     Tcl_IncrRefCount(invoke[2]);
-    TclNRAddCallback(interp, DecrRefsPostClassConstructor,
-	    invoke, oPtr, NULL, NULL);
+    TclNRAddCallback(interp, PostClassConstructor,
+	    invoke, oPtr, delegateName, NULL);
 
     /*
      * Tricky point: do not want the extra reported level in the Tcl stack
@@ -143,33 +258,28 @@ TclOO_Class_Constructor(
     return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL);
 }
 
+/*
+ *	Called *after* [oo::define] inside the constructor of a class.
+ *	Cleans up some temporary storage and sets up the delegate.
+ */
 static int
-DecrRefsPostClassConstructor(
+PostClassConstructor(
     void *data[],
     Tcl_Interp *interp,
     int result)
 {
     Tcl_Obj **invoke = (Tcl_Obj **) data[0];
     Object *oPtr = (Object *) data[1];
-    Tcl_InterpState saved;
-    int code;
+    Tcl_Obj *delegateName = (Tcl_Obj *) data[2];
 
     TclDecrRefCount(invoke[0]);
     TclDecrRefCount(invoke[1]);
     TclDecrRefCount(invoke[2]);
-    invoke[0] = oPtr->fPtr->mcdName;
-    invoke[1] = TclOOObjectName(interp, oPtr);
-    Tcl_IncrRefCount(invoke[0]);
-    Tcl_IncrRefCount(invoke[1]);
-    saved = Tcl_SaveInterpState(interp, result);
-    code = Tcl_EvalObjv(interp, 2, invoke, 0);
-    TclDecrRefCount(invoke[0]);
-    TclDecrRefCount(invoke[1]);
     TclStackFree(interp, invoke);
-    if (code != TCL_OK) {
-	Tcl_DiscardInterpState(saved);
-	return code;
-    }
+
+    Tcl_InterpState saved = Tcl_SaveInterpState(interp, result);
+    MixinClassDelegates(interp, oPtr, delegateName);
+    Tcl_DecrRefCount(delegateName);
     return Tcl_RestoreInterpState(interp, saved);
 }
 
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 1331703..90d5069 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -405,8 +405,6 @@ struct Foundation {
 				 * "<cloned>" pseudo-constructor. */
     Tcl_Obj *defineName;	/* Fully qualified name of oo::define. */
     Tcl_Obj *myName;		/* The "my" shared object. */
-    Tcl_Obj *mcdName;		/* The shared object for calling the helper to
-				 * mix in class delegates. */
     Tcl_Obj *slotGetName;	/* The "Get" name used by slots. */
     Tcl_Obj *slotSetName;	/* The "Set" name used by slots. */
     Tcl_Obj *slotResolveName;	/* The "Resolve" name used by slots. */
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 643e536..bd3721b 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -52,23 +52,6 @@ static const char *tclOOSetupScript =
 "\t\t\trename $cmd {}\n"
 "\t\t}\n"
 "\t}\n"
-"\tproc MixinClassDelegates {class} {\n"
-"\t\tif {![info object isa class $class]} {\n"
-"\t\t\treturn\n"
-"\t\t}\n"
-"\t\tset delegate [DelegateName $class]\n"
-"\t\tif {![info object isa class $delegate]} {\n"
-"\t\t\treturn\n"
-"\t\t}\n"
-"\t\tforeach c [info class superclass $class] {\n"
-"\t\t\tset d [DelegateName $c]\n"
-"\t\t\tif {![info object isa class $d]} {\n"
-"\t\t\t\tcontinue\n"
-"\t\t\t}\n"
-"\t\t\tdefine $delegate ::oo::define::superclass -appendifnew $d\n"
-"\t\t}\n"
-"\t\tobjdefine $class ::oo::objdefine::mixin -appendifnew $delegate\n"
-"\t}\n"
 "\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
 "\t\tset originDelegate [DelegateName $originObject]\n"
 "\t\tset targetDelegate [DelegateName $targetObject]\n"
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 2cf40e1..4509202 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -65,33 +65,6 @@
 
     # ----------------------------------------------------------------------
     #
-    # MixinClassDelegates --
-    #
-    #	Support code called *after* [oo::define] inside the constructor of a
-    #	class that patches in the appropriate class delegates.
-    #
-    # ----------------------------------------------------------------------
-
-    proc MixinClassDelegates {class} {
-	if {![info object isa class $class]} {
-	    return
-	}
-	set delegate [DelegateName $class]
-	if {![info object isa class $delegate]} {
-	    return
-	}
-	foreach c [info class superclass $class] {
-	    set d [DelegateName $c]
-	    if {![info object isa class $d]} {
-		continue
-	    }
-	    define $delegate ::oo::define::superclass -appendifnew $d
-	}
-	objdefine $class ::oo::objdefine::mixin -appendifnew $delegate
-    }
-
-    # ----------------------------------------------------------------------
-    #
     # UpdateClassDelegatesAfterClone --
     #
     #	Support code that is like [MixinClassDelegates] except for when a
-- 
cgit v0.12


From 1e47aa3a2e2d85795e56613c97a47a6777e153d1 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 22 Aug 2025 07:50:00 +0000
Subject: Move another definition (classmethod) into C.

---
 generic/tclOO.c           |  1 +
 generic/tclOODefineCmds.c | 66 +++++++++++++++++++++++++++++++++++++++++++++++
 generic/tclOOInt.h        |  1 +
 generic/tclOOScript.h     | 13 ----------
 tools/tclOOScript.tcl     | 28 --------------------
 5 files changed, 68 insertions(+), 41 deletions(-)

diff --git a/generic/tclOO.c b/generic/tclOO.c
index 0ef69a4..3eeeb80 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -25,6 +25,7 @@ static const struct {
     Tcl_ObjCmdProc *objProc;
     int flag;
 } defineCmds[] = {
+    {"classmethod", TclOODefineClassMethodObjCmd, 0},
     {"constructor", TclOODefineConstructorObjCmd, 0},
     {"definitionnamespace", TclOODefineDefnNsObjCmd, 0},
     {"deletemethod", TclOODefineDeleteMethodObjCmd, 0},
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 199fce7..40c4fe0 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -2228,6 +2228,72 @@ TclOODefineMethodObjCmd(
 /*
  * ----------------------------------------------------------------------
  *
+ * TclOODefineClassMethodObjCmd --
+ *
+ *	Implementation of the "classmethod" subcommand of the "oo::define"
+ *	command. Defines a class method. See define(n) for details.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineClassMethodObjCmd(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    if (objc != 2 && objc != 4) {
+	Tcl_WrongNumArgs(interp, 1, objv, "name ?args body?");
+	return TCL_ERROR;
+    }
+    Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
+    if (!clsPtr) {
+	return TCL_ERROR;
+    }
+
+    int isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
+	    ? PUBLIC_METHOD : 0;
+
+    // Create the method on the delegate class if the caller gave arguments and body
+    if (objc == 4) {
+	Tcl_Obj *delegateName = Tcl_ObjPrintf("%s:: oo ::delegate",
+		clsPtr->thisPtr->namespacePtr->fullName);
+	Class *delegatePtr = TclOOGetClassFromObj(interp, delegateName);
+	Tcl_DecrRefCount(delegateName);
+	if (!delegatePtr) {
+	    return TCL_ERROR;
+	}
+	if (IsPrivateDefine(interp)) {
+	    isPublic = 0;
+	}
+	if (TclOONewProcMethod(interp, delegatePtr, isPublic, objv[1],
+		objv[2], objv[3], NULL) == NULL) {
+	    return TCL_ERROR;
+	}
+    }
+
+    // Make the connection to the delegate by forwarding
+    if (IsPrivateDefine(interp)) {
+	isPublic = TRUE_PRIVATE_METHOD;
+    }
+    Tcl_Obj *forwardArgs[] = {
+	Tcl_NewStringObj("myclass", -1),
+	objv[1]
+    };
+    Tcl_Obj *prefixObj = Tcl_NewListObj(2, forwardArgs);
+    Method *mPtr = TclOONewForwardMethod(interp, clsPtr, isPublic,
+	    objv[1], prefixObj);
+    if (mPtr == NULL) {
+	Tcl_DecrRefCount(prefixObj);
+	return TCL_ERROR;
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * TclOODefineRenameMethodObjCmd --
  *
  *	Implementation of the "renamemethod" subcommand of the "oo::define"
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 90d5069..7ea5999 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -500,6 +500,7 @@ struct DeclaredClassMethod {
 MODULE_SCOPE int		TclOOInit(Tcl_Interp *interp);
 MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOObjDefObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineClassMethodObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineConstructorObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineDefnNsObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineDeleteMethodObjCmd;
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index bd3721b..4a69bc8 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -66,19 +66,6 @@ static const char *tclOOSetupScript =
 "\t\t\t\t}]\n"
 "\t\t}\n"
 "\t}\n"
-"\tproc define::classmethod {name args} {\n"
-"\t\t::set argc [::llength [::info level 0]]\n"
-"\t\t::if {$argc == 3} {\n"
-"\t\t\t::return -code error -errorcode {TCL WRONGARGS} [::format \\\n"
-"\t\t\t\t{wrong # args: should be \"%s name \?args body\?\"} \\\n"
-"\t\t\t\t[::lindex [::info level 0] 0]]\n"
-"\t\t}\n"
-"\t\t::set cls [::uplevel 1 self]\n"
-"\t\t::if {$argc == 4} {\n"
-"\t\t\t::oo::define [::oo::DelegateName $cls] method $name {*}$args\n"
-"\t\t}\n"
-"\t\t::tailcall forward $name myclass $name\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"
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 4509202..e480aac 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -90,34 +90,6 @@
 
     # ----------------------------------------------------------------------
     #
-    # oo::define::classmethod --
-    #
-    #	Defines a class method. 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::classmethod {name args} {
-	# Create the method on the class if the caller gave arguments and body
-	::set argc [::llength [::info level 0]]
-	::if {$argc == 3} {
-	    ::return -code error -errorcode {TCL WRONGARGS} [::format \
-		{wrong # args: should be "%s name ?args body?"} \
-		[::lindex [::info level 0] 0]]
-	}
-	::set cls [::uplevel 1 self]
-	::if {$argc == 4} {
-	    ::oo::define [::oo::DelegateName $cls] method $name {*}$args
-	}
-	# Make the connection by forwarding
-	::tailcall forward $name myclass $name
-    }
-
-    # ----------------------------------------------------------------------
-    #
     # Slot --
     #
     #	The class of slot operations, which are basically lists at the low
-- 
cgit v0.12


From 6a89806ee62b84b96bafb2d86c0726a9408fbe0f Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 22 Aug 2025 11:45:24 +0000
Subject: Move [link] into C.

---
 generic/tclInt.h      |  4 +++
 generic/tclInterp.c   | 20 +++++------
 generic/tclOO.c       | 14 ++++++++
 generic/tclOOBasic.c  | 92 +++++++++++++++++++++++++++++++++++++++++++++++++++
 generic/tclOOInt.h    |  2 ++
 generic/tclOOScript.h | 25 --------------
 tools/tclOOScript.tcl | 51 ----------------------------
 7 files changed, 120 insertions(+), 88 deletions(-)

diff --git a/generic/tclInt.h b/generic/tclInt.h
index 096d5e7..9252eb8 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3282,6 +3282,10 @@ MODULE_SCOPE void	TclAdvanceContinuations(int *line, Tcl_Size **next,
 			    Tcl_Size loc);
 MODULE_SCOPE void	TclAdvanceLines(int *line, const char *start,
 			    const char *end);
+MODULE_SCOPE int	TclAliasCreate(Tcl_Interp *interp,
+			    Tcl_Interp *childInterp, Tcl_Interp *parentInterp,
+			    Tcl_Obj *namePtr, Tcl_Obj *targetPtr, Tcl_Size objc,
+			    Tcl_Obj *const objv[]);
 MODULE_SCOPE void	TclAppendBytesToByteArray(Tcl_Obj *objPtr,
 			    const unsigned char *bytes, Tcl_Size len);
 MODULE_SCOPE void	TclAppendUtfToUtf(Tcl_Obj *objPtr,
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 061ddcf..77d06f6 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -221,10 +221,6 @@ enum LimitHandlerFlags {
  * Prototypes for local static functions:
  */
 
-static int		AliasCreate(Tcl_Interp *interp,
-			    Tcl_Interp *childInterp, Tcl_Interp *parentInterp,
-			    Tcl_Obj *namePtr, Tcl_Obj *targetPtr, Tcl_Size objc,
-			    Tcl_Obj *const objv[]);
 static int		AliasDelete(Tcl_Interp *interp,
 			    Tcl_Interp *childInterp, Tcl_Obj *namePtr);
 static int		AliasDescribe(Tcl_Interp *interp,
@@ -701,7 +697,7 @@ NRInterpCmd(
 		return TCL_ERROR;
 	    }
 
-	    return AliasCreate(interp, childInterp, parentInterp, objv[3],
+	    return TclAliasCreate(interp, childInterp, parentInterp, objv[3],
 		    objv[5], objc - 6, objv + 6);
 	}
 
@@ -1232,7 +1228,7 @@ Tcl_CreateAlias(
     targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
     Tcl_IncrRefCount(targetObjPtr);
 
-    result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
+    result = TclAliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
 	    targetObjPtr, argc, objv);
 
     for (i = 0; i < argc; i++) {
@@ -1279,7 +1275,7 @@ Tcl_CreateAliasObj(
     targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
     Tcl_IncrRefCount(targetObjPtr);
 
-    result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
+    result = TclAliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
 	    targetObjPtr, objc, objv);
 
     Tcl_DecrRefCount(childObjPtr);
@@ -1452,7 +1448,7 @@ TclPreventAliasLoop(
 /*
  *----------------------------------------------------------------------
  *
- * AliasCreate --
+ * TclAliasCreate --
  *
  *	Helper function to do the work to actually create an alias.
  *
@@ -1466,8 +1462,8 @@ TclPreventAliasLoop(
  *----------------------------------------------------------------------
  */
 
-static int
-AliasCreate(
+int
+TclAliasCreate(
     Tcl_Interp *interp,		/* Interp for error reporting. */
     Tcl_Interp *childInterp,	/* Interp where alias cmd will live or from
 				 * which alias will be deleted. */
@@ -2468,7 +2464,7 @@ ChildCreate(
 
 	TclNewLiteralStringObj(clockObj, "clock");
 	Tcl_IncrRefCount(clockObj);
-	status = AliasCreate(interp, childInterp, parentInterp, clockObj,
+	status = TclAliasCreate(interp, childInterp, parentInterp, clockObj,
 		clockObj, 0, NULL);
 	Tcl_DecrRefCount(clockObj);
 	if (status != TCL_OK) {
@@ -2558,7 +2554,7 @@ NRChildCmd(
 		    return AliasDelete(interp, childInterp, objv[2]);
 		}
 	    } else {
-		return AliasCreate(interp, childInterp, interp, objv[2],
+		return TclAliasCreate(interp, childInterp, interp, objv[2],
 			objv[3], objc - 4, objv + 4);
 	    }
 	}
diff --git a/generic/tclOO.c b/generic/tclOO.c
index e0cde38..d7dea8d 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -445,6 +445,8 @@ InitFoundation(
 	    TclOOCallbackObjCmd, NULL, NULL, 0);
     CreateCmdInNS(interp, fPtr->helpersNs, "classvariable",
 	    TclOOClassVariableObjCmd, NULL, NULL, 0);
+    CreateCmdInNS(interp, fPtr->helpersNs, "link",
+	    TclOOLinkObjCmd, NULL, NULL, 0);
     CreateCmdInNS(interp, fPtr->helpersNs, "next",
 	    NULL, TclOONextObjCmd, TclCompileObjectNextCmd, CMD_COMPILES_EXPANDED);
     CreateCmdInNS(interp, fPtr->helpersNs, "nextto",
@@ -817,6 +819,7 @@ AllocObject(
     oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass",
 	    oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr,
 	    MyClassDeleted);
+    oPtr->linkedCmdsList = NULL;
     return oPtr;
 }
 
@@ -861,6 +864,17 @@ MyDeleted(
 {
     Object *oPtr = (Object *) clientData;
 
+    if (oPtr->linkedCmdsList) {
+	Tcl_Size linkc, i;
+	Tcl_Obj **linkv;
+	TclListObjGetElements(NULL, oPtr->linkedCmdsList, &linkc, &linkv);
+	for (i=0 ; i<linkc ; i++) {
+	    Tcl_Obj *link = linkv[i];
+	    (void) Tcl_DeleteCommand(oPtr->fPtr->interp, TclGetString(link));
+	}
+	Tcl_DecrRefCount(oPtr->linkedCmdsList);
+	oPtr->linkedCmdsList = NULL;
+    }
     oPtr->myCommand = NULL;
 }
 
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 18dd5e9..6884db6 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -1014,6 +1014,98 @@ TclOO_Object_VarName(
 /*
  * ----------------------------------------------------------------------
  *
+ * TclOOLinkObjCmd --
+ *
+ *	Implementation of the [link] command, that makes a command that
+ *	invokes a method on the current object. The name of the command and
+ *	the name of the method match by default. Note that this command is
+ *	only ever to be used inside the body of a procedure-like method,
+ *	and is typically intended for constructors.
+ *
+ * ----------------------------------------------------------------------
+ */
+int
+TclOOLinkObjCmd(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    // Set up common bits.
+    CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
+    if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"%s may only be called from inside a method",
+		TclGetString(objv[0])));
+	OO_ERROR(interp, CONTEXT_REQUIRED);
+	return TCL_ERROR;
+    }
+    CallContext *context = (CallContext *) framePtr->clientData;
+    Object *oPtr = context->oPtr;
+    if (!oPtr->myCommand) {
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"cannot link to non-existent callback handle"));
+	OO_ERROR(interp, MY_GONE);
+	return TCL_ERROR;
+    }
+    Tcl_Obj *myCmd = Tcl_NewObj();
+    Tcl_GetCommandFullName(interp, oPtr->myCommand, myCmd);
+    if (!oPtr->linkedCmdsList) {
+	oPtr->linkedCmdsList = Tcl_NewListObj(0, NULL);
+	Tcl_IncrRefCount(oPtr->linkedCmdsList);
+    }
+
+    // For each argument
+    for (int i=1; i<objc; i++) {
+	Tcl_Size linkc;
+	Tcl_Obj **linkv, *src, *dst;
+
+	// Parse as list of (one or) two items: source and destination names
+	if (TclListObjGetElements(interp, objv[i], &linkc, &linkv) != TCL_OK) {
+	    Tcl_BounceRefCount(myCmd);
+	    return TCL_ERROR;
+	}
+	switch (linkc) {
+	case 1:
+	    // Degenerate case
+	    src = dst = linkv[0];
+	    break;
+	case 2:
+	    src = linkv[0];
+	    dst = linkv[1];
+	    break;
+	default:
+	    Tcl_BounceRefCount(myCmd);
+	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		    "bad link description; must only have one or two elements"));
+	    OO_ERROR(interp, CMDLINK_FORMAT);
+	    return TCL_ERROR;
+	}
+
+	// Qualify the source if necessary
+	const char *srcStr = TclGetString(src);
+	if (srcStr[0] != ':' || srcStr[1] != ':') {
+	    src = Tcl_ObjPrintf("%s::%s",
+		    context->oPtr->namespacePtr->fullName, srcStr);
+	}
+
+	// Make the alias command
+	if (TclAliasCreate(interp, interp, interp, src, myCmd, 1, &dst) != TCL_OK) {
+	    Tcl_BounceRefCount(myCmd);
+	    Tcl_BounceRefCount(src);
+	    return TCL_ERROR;
+	}
+
+	// Remember the alias for cleanup if necessary
+	Tcl_ListObjAppendElement(NULL, oPtr->linkedCmdsList, src);
+    }
+    Tcl_BounceRefCount(myCmd);
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * TclOONextObjCmd, TclOONextToObjCmd --
  *
  *	Implementation of the [next] and [nextto] commands. Note that these
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 7ea5999..777c7fa 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -255,6 +255,7 @@ struct Object {
     PropertyStorage properties;	/* Information relating to the lists of
 				 * properties that this object *claims* to
 				 * support. */
+    Tcl_Obj *linkedCmdsList;	/* List of names of linked commands. */
 };
 
 enum ObjectFlags {
@@ -521,6 +522,7 @@ MODULE_SCOPE Tcl_ObjCmdProc	TclOOCallbackObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOClassVariableObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOCopyObjectCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOODelegateNameObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc	TclOOLinkObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOONextObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOONextToObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOSelfObjCmd;
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 4a69bc8..79379d3 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -27,31 +27,6 @@
 static const char *tclOOSetupScript =
 /* !BEGIN!: Do not edit below this line. */
 "::namespace eval ::oo {\n"
-"\tproc Helpers::link {args} {\n"
-"\t\tset ns [uplevel 1 {::namespace current}]\n"
-"\t\tforeach link $args {\n"
-"\t\t\tif {[llength $link] == 2} {\n"
-"\t\t\t\tlassign $link src dst\n"
-"\t\t\t} elseif {[llength $link] == 1} {\n"
-"\t\t\t\tlassign $link src\n"
-"\t\t\t\tset dst $src\n"
-"\t\t\t} else {\n"
-"\t\t\t\treturn -code error -errorcode {TCL OO CMDLINK_FORMAT} \\\n"
-"\t\t\t\t\t\"bad link description; must only have one or two elements\"\n"
-"\t\t\t}\n"
-"\t\t\tif {![string match ::* $src]} {\n"
-"\t\t\t\tset src [string cat $ns :: $src]\n"
-"\t\t\t}\n"
-"\t\t\tinterp alias {} $src {} ${ns}::my $dst\n"
-"\t\t\ttrace add command ${ns}::my delete [list \\\n"
-"\t\t\t\t::oo::UnlinkLinkedCommand $src]\n"
-"\t\t}\n"
-"\t}\n"
-"\tproc UnlinkLinkedCommand {cmd args} {\n"
-"\t\tif {[namespace which $cmd] ne {}} {\n"
-"\t\t\trename $cmd {}\n"
-"\t\t}\n"
-"\t}\n"
 "\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
 "\t\tset originDelegate [DelegateName $originObject]\n"
 "\t\tset targetDelegate [DelegateName $targetObject]\n"
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index e480aac..8bb214a 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -12,57 +12,6 @@
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
 ::namespace eval ::oo {
-
-    #
-    # Commands that are made available to objects by default.
-    #
-
-    # ------------------------------------------------------------------
-    #
-    # link --
-    #
-    #	Make a command that invokes a method on the current object.
-    #	The name of the command and the name of the method match by
-    #	default.
-    #
-    # ------------------------------------------------------------------
-
-    proc Helpers::link {args} {
-	set ns [uplevel 1 {::namespace current}]
-	foreach link $args {
-	    if {[llength $link] == 2} {
-		lassign $link src dst
-	    } elseif {[llength $link] == 1} {
-		lassign $link src
-		set dst $src
-	    } else {
-		return -code error -errorcode {TCL OO CMDLINK_FORMAT} \
-		    "bad link description; must only have one or two elements"
-	    }
-	    if {![string match ::* $src]} {
-		set src [string cat $ns :: $src]
-	    }
-	    interp alias {} $src {} ${ns}::my $dst
-	    trace add command ${ns}::my delete [list \
-		::oo::UnlinkLinkedCommand $src]
-	}
-    }
-
-    # ----------------------------------------------------------------------
-    #
-    # UnlinkLinkedCommand --
-    #
-    #	Callback used to remove linked command when the underlying mechanism
-    #	that supports it is deleted.
-    #
-    # ----------------------------------------------------------------------
-
-    proc UnlinkLinkedCommand {cmd args} {
-	if {[namespace which $cmd] ne {}} {
-	    rename $cmd {}
-	}
-    }
-
     # ----------------------------------------------------------------------
     #
     # UpdateClassDelegatesAfterClone --
-- 
cgit v0.12


From 65b29252affc1999b4c72236b728b848e7a732f5 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Fri, 22 Aug 2025 12:50:28 +0000
Subject: Fix handling of i386-x86_64

---
 library/platform/platform.tcl | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

diff --git a/library/platform/platform.tcl b/library/platform/platform.tcl
index d188a5e..97bf815 100644
--- a/library/platform/platform.tcl
+++ b/library/platform/platform.tcl
@@ -348,13 +348,14 @@ proc ::platform::patterns {id} {
 	    # 10.5+,11.0+
 	    if {[regexp {macosx?([^-]*)-(.*)} $id -> v cpu]} {
 
+		foreach {major minor} [split $v.15 .] break
 		switch -exact -- $cpu {
 		    ix86    {
 			lappend alt i386-x86_64
 			lappend alt universal
 		    }
 		    x86_64  {
-			if {[lindex [split $::tcl_platform(osVersion) .] 0] < 19} {
+			if {$major < 11 && $minor < 15} {
 			    set alt i386-x86_64
 			} else {
 			    set alt {}
@@ -367,7 +368,6 @@ proc ::platform::patterns {id} {
 		}
 
 		if {$v ne ""} {
-		    foreach {major minor} [split $v.15 .] break
 		    set res {}
 		    while {$major > 10} {
 			# Add $major to patterns.
@@ -385,6 +385,9 @@ proc ::platform::patterns {id} {
 			if {$cpu ne "arm"} {
 			    lappend res macosx${major}.${j}-${cpu}
 			}
+			if {($cpu eq "x86_64") && ($j == 14)} {
+			    set alt i386-x86_64
+			}
 			foreach a $alt {
 			    lappend res macosx${major}.${j}-$a
 			}
-- 
cgit v0.12


From dace3996715c6a8f97b7c0a89e849df13c2be5f9 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Fri, 22 Aug 2025 13:06:31 +0000
Subject: Add testcases for platform macos26-x86_64 and macos26-arm

---
 tests/platform.test | 6 ++++++
 1 file changed, 6 insertions(+)

diff --git a/tests/platform.test b/tests/platform.test
index 1b49b40..5833a9f 100644
--- a/tests/platform.test
+++ b/tests/platform.test
@@ -97,6 +97,12 @@ test platform-5.0 {format of platform::generic result} -setup {
     set ::tcl_platform(osVersion) $old_version
     unset res l old_machine old_os old_wordsize old_version
 } -result {macos11-arm 1 macos12-arm 1 macos13-arm 1 macos14-arm 1 macos15-arm 1 macos26-arm 1 macos27-arm 1}
+test platform-5.1 {format of platform::patterns macos26-x86_64} -body {
+    platform::patterns macos26-x86_64
+} -result {macos26-x86_64 macos15-x86_64 macos14-x86_64 macos13-x86_64 macos12-x86_64 macos11-x86_64 macosx10.15-x86_64 macosx10.14-x86_64 macosx10.14-i386-x86_64 macosx10.13-x86_64 macosx10.13-i386-x86_64 macosx10.12-x86_64 macosx10.12-i386-x86_64 macosx10.11-x86_64 macosx10.11-i386-x86_64 macosx10.10-x86_64 macosx10.10-i386-x86_64 macosx10.9-x86_64 macosx10.9-i386-x86_64 tcl}
+test platform-5.2 {format of platform::patterns macos26-arm} -body {
+    platform::patterns macos26-arm
+} -result {macos26-arm macos26-x86_64 macos15-arm macos15-x86_64 macos14-arm macos14-x86_64 macos13-arm macos13-x86_64 macos12-arm macos12-x86_64 macos11-arm macos11-x86_64 macosx10.15-x86_64 macosx10.14-x86_64 macosx10.13-x86_64 macosx10.12-x86_64 macosx10.11-x86_64 macosx10.10-x86_64 macosx10.9-x86_64 tcl}
 
 # cleanup
 cleanupTests
-- 
cgit v0.12


From eb5871174066e297e0975aa323f7fb1b37c2fcbe Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 22 Aug 2025 13:43:50 +0000
Subject: Combine UpdateClassDelegatesAfterClone into its caller.

---
 generic/tclOOScript.h | 32 +++++++++++++++-----------------
 tools/tclOOScript.tcl | 43 +++++++++++++++----------------------------
 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"
 		}
 	    }
-- 
cgit v0.12


From 800194c7f4ddd68ec444f5a350867e546283e35c Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 22 Aug 2025 14:23:56 +0000
Subject: Tweak to [configurable] to not call [next] twice

---
 generic/tclOOScript.h | 2 +-
 tools/tclOOScript.tcl | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 0bec4fa..318a7ac 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -115,7 +115,7 @@ static const char *tclOOSetupScript =
 "\tclass create configurable\n"
 "\tdefine configurable superclass -set class\n"
 "\tdefine configurable constructor {{definitionScript \"\"}} {\n"
-"\t\tnext {mixin ::oo::configuresupport::configurable}\n"
+"\t\too::define [self] {mixin -append ::oo::configuresupport::configurable}\n"
 "\t\tnext $definitionScript\n"
 "\t}\n"
 "\tdefine configurable definitionnamespace -class configuresupport::configurableclass\n"
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index d871d57..66e125d 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -232,7 +232,7 @@
     class create configurable
     define configurable superclass -set class
     define configurable constructor {{definitionScript ""}} {
-	next {mixin ::oo::configuresupport::configurable}
+	::oo::define [self] {mixin -append ::oo::configuresupport::configurable}
 	next $definitionScript
     }
 
-- 
cgit v0.12


From 0321a464b9c1ac2a010dd0cc222f590fa1f03140 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 24 Aug 2025 06:52:11 +0000
Subject: Complete the moving of the definition of slots entirely into C

---
 generic/tclOO.c           |  69 +++++++++----------
 generic/tclOODefineCmds.c | 164 +++++++++++++++++++++++++++++++---------------
 generic/tclOOScript.h     |   7 +-
 tools/tclOOScript.tcl     |  27 --------
 4 files changed, 144 insertions(+), 123 deletions(-)

diff --git a/generic/tclOO.c b/generic/tclOO.c
index b50919b..1fa9470 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -52,31 +52,31 @@ static const struct DefineCommands {
     Tcl_ObjCmdProc *objProc;
     int flag;
 } defineCmds[] = {
-    {"classmethod", TclOODefineClassMethodObjCmd, 0},
-    {"constructor", TclOODefineConstructorObjCmd, 0},
+    {"classmethod",	TclOODefineClassMethodObjCmd, 0},
+    {"constructor",	TclOODefineConstructorObjCmd, 0},
     {"definitionnamespace", TclOODefineDefnNsObjCmd, 0},
-    {"deletemethod", TclOODefineDeleteMethodObjCmd, 0},
-    {"destructor", TclOODefineDestructorObjCmd, 0},
-    {"export", TclOODefineExportObjCmd, 0},
-    {"forward", TclOODefineForwardObjCmd, 0},
-    {"initialise", TclOODefineInitialiseObjCmd, 0},
-    {"initialize", TclOODefineInitialiseObjCmd, 0},
-    {"method", TclOODefineMethodObjCmd, 0},
-    {"private", TclOODefinePrivateObjCmd, 0},
-    {"renamemethod", TclOODefineRenameMethodObjCmd, 0},
-    {"self", TclOODefineSelfObjCmd, 0},
-    {"unexport", TclOODefineUnexportObjCmd, 0},
+    {"deletemethod",	TclOODefineDeleteMethodObjCmd, 0},
+    {"destructor",	TclOODefineDestructorObjCmd, 0},
+    {"export",		TclOODefineExportObjCmd, 0},
+    {"forward",		TclOODefineForwardObjCmd, 0},
+    {"initialise",	TclOODefineInitialiseObjCmd, 0},
+    {"initialize",	TclOODefineInitialiseObjCmd, 0},
+    {"method",		TclOODefineMethodObjCmd, 0},
+    {"private",		TclOODefinePrivateObjCmd, 0},
+    {"renamemethod",	TclOODefineRenameMethodObjCmd, 0},
+    {"self",		TclOODefineSelfObjCmd, 0},
+    {"unexport",	TclOODefineUnexportObjCmd, 0},
     {NULL, NULL, 0}
 }, objdefCmds[] = {
-    {"class", TclOODefineClassObjCmd, 1},
-    {"deletemethod", TclOODefineDeleteMethodObjCmd, 1},
-    {"export", TclOODefineExportObjCmd, 1},
-    {"forward", TclOODefineForwardObjCmd, 1},
-    {"method", TclOODefineMethodObjCmd, 1},
-    {"private", TclOODefinePrivateObjCmd, 1},
-    {"renamemethod", TclOODefineRenameMethodObjCmd, 1},
-    {"self", TclOODefineObjSelfObjCmd, 0},
-    {"unexport", TclOODefineUnexportObjCmd, 1},
+    {"class",		TclOODefineClassObjCmd, 1},
+    {"deletemethod",	TclOODefineDeleteMethodObjCmd, 1},
+    {"export",		TclOODefineExportObjCmd, 1},
+    {"forward",		TclOODefineForwardObjCmd, 1},
+    {"method",		TclOODefineMethodObjCmd, 1},
+    {"private",		TclOODefinePrivateObjCmd, 1},
+    {"renamemethod",	TclOODefineRenameMethodObjCmd, 1},
+    {"self",		TclOODefineObjSelfObjCmd, 0},
+    {"unexport",	TclOODefineUnexportObjCmd, 1},
     {NULL, NULL, 0}
 };
 
@@ -97,7 +97,7 @@ static int		CloneClassMethod(Tcl_Interp *interp, Class *clsPtr,
 			    Method **newMPtrPtr);
 static int		CloneObjectMethod(Tcl_Interp *interp, Object *oPtr,
 			    Method *mPtr, Tcl_Obj *namePtr);
-static void		DeletedHelpersNamespace(void *clientData);
+static Tcl_NamespaceDeleteProc	DeletedHelpersNamespace;
 static Tcl_NRPostProc	FinalizeAlloc;
 static Tcl_NRPostProc	FinalizeNext;
 static Tcl_NRPostProc	FinalizeObjectCall;
@@ -106,23 +106,17 @@ static void		InitClassSystemRoots(Tcl_Interp *interp,
 			    Foundation *fPtr);
 static int		InitFoundation(Tcl_Interp *interp);
 static Tcl_InterpDeleteProc	KillFoundation;
-static void		MyDeleted(void *clientData);
-static void		ObjectNamespaceDeleted(void *clientData);
+static Tcl_CmdDeleteProc	MyDeleted;
+static Tcl_NamespaceDeleteProc	ObjectNamespaceDeleted;
 static Tcl_CommandTraceProc	ObjectRenamedTrace;
 static inline void	RemoveClass(Class **list, size_t num, size_t idx);
 static inline void	RemoveObject(Object **list, size_t num, size_t idx);
 static inline void	SquelchCachedName(Object *oPtr);
 
-static int		PublicNRObjectCmd(void *clientData,
-			    Tcl_Interp *interp, int objc,
-			    Tcl_Obj *const *objv);
-static int		PrivateNRObjectCmd(void *clientData,
-			    Tcl_Interp *interp, int objc,
-			    Tcl_Obj *const *objv);
-static int		MyClassNRObjCmd(void *clientData,
-			    Tcl_Interp *interp, int objc,
-			    Tcl_Obj *const *objv);
-static void		MyClassDeleted(void *clientData);
+static Tcl_ObjCmdProc	PublicNRObjectCmd;
+static Tcl_ObjCmdProc	PrivateNRObjectCmd;
+static Tcl_ObjCmdProc	MyClassNRObjCmd;
+static Tcl_CmdDeleteProc	MyClassDeleted;
 
 /*
  * Methods in the oo::object and oo::class classes. First, we define a helper
@@ -173,8 +167,9 @@ static const char initScript[] =
 "package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
 #endif
 "package ifneeded tcl::oo " TCLOO_PATCHLEVEL " {# Already present, OK?};"
-"namespace eval ::oo { variable version " TCLOO_VERSION " };"
-"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
+"namespace eval ::oo {"
+"    variable version " TCLOO_VERSION " patchlevel " TCLOO_PATCHLEVEL
+"};";
 /* "tcl_findLibrary tcloo $oo::version $oo::version" */
 /* " tcloo.tcl OO_LIBRARY oo::library;"; */
 
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 40c4fe0..0b1495a 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -37,16 +37,17 @@ typedef struct DeclaredSlot {
     const Tcl_MethodType getterType;
     const Tcl_MethodType setterType;
     const Tcl_MethodType resolverType;
+    const char *defaultOp;	// The default op, if not set by the class
 } DeclaredSlot;
 
-#define SLOT(name,getter,setter,resolver) \
+#define SLOT(name,getter,setter,resolver,defOp) \
     {"::oo::" name,							\
 	    {TCL_OO_METHOD_VERSION_1, "core method: " name " Getter",	\
 		    getter, NULL, NULL},				\
 	    {TCL_OO_METHOD_VERSION_1, "core method: " name " Setter",	\
 		    setter, NULL, NULL},				\
 	    {TCL_OO_METHOD_VERSION_1, "core method: " name " Resolver",	\
-		    resolver, NULL, NULL}}
+		    resolver, NULL, NULL}, (defOp)}
 
 typedef struct DeclaredSlotMethod {
     const char *name;
@@ -190,26 +191,26 @@ static int		ResolveClass(void *clientData,
  */
 
 static const DeclaredSlot slots[] = {
-    SLOT("define::filter",      ClassFilter_Get, ClassFilter_Set, NULL),
-    SLOT("define::mixin",       ClassMixin_Get,  ClassMixin_Set, ResolveClass),
-    SLOT("define::superclass",  ClassSuper_Get,  ClassSuper_Set, ResolveClass),
-    SLOT("define::variable",    ClassVars_Get,   ClassVars_Set, NULL),
-    SLOT("objdefine::filter",   ObjFilter_Get,   ObjFilter_Set, NULL),
-    SLOT("objdefine::mixin",    ObjMixin_Get,    ObjMixin_Set, ResolveClass),
-    SLOT("objdefine::variable", ObjVars_Get,     ObjVars_Set, NULL),
+    SLOT("define::filter",      ClassFilter_Get, ClassFilter_Set, NULL, NULL),
+    SLOT("define::mixin",       ClassMixin_Get,  ClassMixin_Set, ResolveClass, "-set"),
+    SLOT("define::superclass",  ClassSuper_Get,  ClassSuper_Set, ResolveClass, "-set"),
+    SLOT("define::variable",    ClassVars_Get,   ClassVars_Set, NULL, NULL),
+    SLOT("objdefine::filter",   ObjFilter_Get,   ObjFilter_Set, NULL, NULL),
+    SLOT("objdefine::mixin",    ObjMixin_Get,    ObjMixin_Set, ResolveClass, "-set"),
+    SLOT("objdefine::variable", ObjVars_Get,     ObjVars_Set, NULL, NULL),
     SLOT("configuresupport::readableproperties",
 	    Configurable_ClassReadableProps_Get,
-	    Configurable_ClassReadableProps_Set, NULL),
+	    Configurable_ClassReadableProps_Set, NULL, NULL),
     SLOT("configuresupport::writableproperties",
 	    Configurable_ClassWritableProps_Get,
-	    Configurable_ClassWritableProps_Set, NULL),
+	    Configurable_ClassWritableProps_Set, NULL, NULL),
     SLOT("configuresupport::objreadableproperties",
 	    Configurable_ObjectReadableProps_Get,
-	    Configurable_ObjectReadableProps_Set, NULL),
+	    Configurable_ObjectReadableProps_Set, NULL, NULL),
     SLOT("configuresupport::objwritableproperties",
 	    Configurable_ObjectWritableProps_Get,
-	    Configurable_ObjectWritableProps_Set, NULL),
-    {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
+	    Configurable_ObjectWritableProps_Set, NULL, NULL),
+    {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, 0}
 };
 
 static const DeclaredSlotMethod slotMethods[] = {
@@ -2349,6 +2350,75 @@ TclOODefineRenameMethodObjCmd(
 }
 
 /*
+ * Unexporting is done by removing the PUBLIC_METHOD flag from the method
+ * record. If there is no such method in this object or class (i.e. the method
+ * comes from something inherited from or that we're an instance of) then we
+ * put in a blank record without that flag; such records are skipped over by
+ * the call chain engine *except* for their flags member.
+ *
+ * Caller has the responsibility to update any epochs if necessary.
+ */
+
+static int
+UnexportMethod(
+    Class *clsPtr,
+    Tcl_Obj *namePtr)
+{
+    int isNew;
+    Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, namePtr,
+		    &isNew);
+    Method *mPtr;
+    if (isNew) {
+	mPtr = (Method *) Tcl_Alloc(sizeof(Method));
+	memset(mPtr, 0, sizeof(Method));
+	mPtr->refCount = 1;
+	mPtr->namePtr = namePtr;
+	Tcl_IncrRefCount(namePtr);
+	Tcl_SetHashValue(hPtr, mPtr);
+    } else {
+	mPtr = (Method *) Tcl_GetHashValue(hPtr);
+    }
+    if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
+	mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
+	isNew = 1;
+    }
+    return isNew;
+}
+
+static int
+UnexportInstanceMethod(
+    Object *oPtr,
+    Tcl_Obj *namePtr)
+{
+    if (!oPtr->methodsPtr) {
+	oPtr->methodsPtr = (Tcl_HashTable *)
+		Tcl_Alloc(sizeof(Tcl_HashTable));
+	Tcl_InitObjHashTable(oPtr->methodsPtr);
+	oPtr->flags &= ~USE_CLASS_CACHE;
+    }
+
+    int isNew;
+    Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, namePtr,
+	    &isNew);
+    Method *mPtr;
+    if (isNew) {
+	mPtr = (Method *) Tcl_Alloc(sizeof(Method));
+	memset(mPtr, 0, sizeof(Method));
+	mPtr->refCount = 1;
+	mPtr->namePtr = namePtr;
+	Tcl_IncrRefCount(namePtr);
+	Tcl_SetHashValue(hPtr, mPtr);
+    } else {
+	mPtr = (Method *) Tcl_GetHashValue(hPtr);
+    }
+    if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
+	mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
+	isNew = 1;
+    }
+    return isNew;
+}
+
+/*
  * ----------------------------------------------------------------------
  *
  * TclOODefineUnexportObjCmd --
@@ -2368,10 +2438,8 @@ TclOODefineUnexportObjCmd(
 {
     int isInstanceUnexport = (clientData != NULL);
     Object *oPtr;
-    Method *mPtr;
-    Tcl_HashEntry *hPtr;
     Class *clsPtr;
-    int i, isNew, changed = 0;
+    int i, changed = 0;
 
     if (objc < 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
@@ -2391,42 +2459,10 @@ TclOODefineUnexportObjCmd(
     }
 
     for (i = 1; i < objc; i++) {
-	/*
-	 * Unexporting is done by removing the PUBLIC_METHOD flag from the
-	 * method record. If there is no such method in this object or class
-	 * (i.e. the method comes from something inherited from or that we're
-	 * an instance of) then we put in a blank record without that flag;
-	 * such records are skipped over by the call chain engine *except* for
-	 * their flags member.
-	 */
-
 	if (isInstanceUnexport) {
-	    if (!oPtr->methodsPtr) {
-		oPtr->methodsPtr = (Tcl_HashTable *)
-			Tcl_Alloc(sizeof(Tcl_HashTable));
-		Tcl_InitObjHashTable(oPtr->methodsPtr);
-		oPtr->flags &= ~USE_CLASS_CACHE;
-	    }
-	    hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, objv[i],
-		    &isNew);
-	} else {
-	    hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, objv[i],
-		    &isNew);
-	}
-
-	if (isNew) {
-	    mPtr = (Method *) Tcl_Alloc(sizeof(Method));
-	    memset(mPtr, 0, sizeof(Method));
-	    mPtr->refCount = 1;
-	    mPtr->namePtr = objv[i];
-	    Tcl_IncrRefCount(objv[i]);
-	    Tcl_SetHashValue(hPtr, mPtr);
+	    changed |= UnexportInstanceMethod(oPtr, objv[i]);
 	} else {
-	    mPtr = (Method *) Tcl_GetHashValue(hPtr);
-	}
-	if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
-	    mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
-	    changed = 1;
+	    changed |= UnexportMethod(clsPtr, objv[i]);
 	}
     }
 
@@ -2504,8 +2540,9 @@ Tcl_ClassSetDestructor(
  *
  * TclOODefineSlots --
  *
- *	Create the "::oo::Slot" class and its standard instances. Class
- *	definition is empty at the stage (added by scripting).
+ *	Create the "::oo::Slot" class and its standard instances. These are
+ *	basically lists at the low level of TclOO; this provides a more
+ *	consistent interface to them.
  *
  * ----------------------------------------------------------------------
  */
@@ -2533,6 +2570,19 @@ TclOODefineSlots(
 	Tcl_BounceRefCount(name);
     }
 
+    // If a slot can't figure out what method to call directly, it uses
+    // --default-operation. That defaults to -append; we set that here.
+    Tcl_Obj *defaults[] = {
+	fPtr->myName,
+	Tcl_NewStringObj("-append", TCL_AUTO_LENGTH)
+    };
+    TclOONewForwardMethod(interp, (Class *) slotCls, 0,
+	    fPtr->slotDefOpName, Tcl_NewListObj(2, defaults));
+
+    // Hide the destroy method. (We're definitely taking a ref to the name.)
+    UnexportMethod((Class *) slotCls,
+	    Tcl_NewStringObj("destroy", TCL_AUTO_LENGTH));
+
     for (const DeclaredSlot *slotPtr = slots ; slotPtr->name ; slotPtr++) {
 	Tcl_Object slotObject = Tcl_NewObjectInstance(interp,
 		slotCls, slotPtr->name, NULL, TCL_INDEX_NONE, NULL, 0);
@@ -2548,6 +2598,14 @@ TclOODefineSlots(
 	    TclNewInstanceMethod(interp, slotObject, fPtr->slotResolveName, 0,
 		    &slotPtr->resolverType, NULL);
 	}
+	if (slotPtr->defaultOp) {
+	    Tcl_Obj *slotDefaults[] = {
+		fPtr->myName,
+		Tcl_NewStringObj(slotPtr->defaultOp, TCL_AUTO_LENGTH)
+	    };
+	    TclOONewForwardInstanceMethod(interp, (Object *) slotObject, 0,
+		    fPtr->slotDefOpName, Tcl_NewListObj(2, slotDefaults));
+	}
     }
     return TCL_OK;
 }
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 318a7ac..4c5f1a2 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -27,11 +27,6 @@
 static const char *tclOOSetupScript =
 /* !BEGIN!: Do not edit below this line. */
 "::namespace eval ::oo {\n"
-"\tdefine Slot forward --default-operation my -append\n"
-"\tdefine Slot unexport destroy\n"
-"\tobjdefine define::superclass forward --default-operation my -set\n"
-"\tobjdefine define::mixin forward --default-operation my -set\n"
-"\tobjdefine objdefine::mixin forward --default-operation my -set\n"
 "\tdefine object method <cloned> -unexport {originObject} {\n"
 "\t\tforeach p [info procs [info object namespace $originObject]::*] {\n"
 "\t\t\tset args [info args $p]\n"
@@ -115,7 +110,7 @@ static const char *tclOOSetupScript =
 "\tclass create configurable\n"
 "\tdefine configurable superclass -set class\n"
 "\tdefine configurable constructor {{definitionScript \"\"}} {\n"
-"\t\too::define [self] {mixin -append ::oo::configuresupport::configurable}\n"
+"\t\t::oo::define [self] {mixin -append ::oo::configuresupport::configurable}\n"
 "\t\tnext $definitionScript\n"
 "\t}\n"
 "\tdefine configurable definitionnamespace -class configuresupport::configurableclass\n"
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 66e125d..6b17483 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -14,33 +14,6 @@
 ::namespace eval ::oo {
     # ----------------------------------------------------------------------
     #
-    # Slot --
-    #
-    #	The class of slot operations, which are basically lists at the low
-    #	level of TclOO; this provides a more consistent interface to them.
-    #
-    # ----------------------------------------------------------------------
-
-    # ------------------------------------------------------------------
-    #
-    # Slot --default-operation --
-    #
-    #	If a slot can't figure out what method to call directly, it
-    #	uses --default-operation.
-    #
-    # ------------------------------------------------------------------
-    define Slot forward --default-operation my -append
-
-    # Hide destroy
-    define Slot unexport destroy
-
-    # Set the default operation differently for these slots
-    objdefine define::superclass forward --default-operation my -set
-    objdefine define::mixin forward --default-operation my -set
-    objdefine objdefine::mixin forward --default-operation my -set
-
-    # ----------------------------------------------------------------------
-    #
     # oo::object <cloned> --
     #
     #	Handler for cloning objects that clones basic bits (only!) of the
-- 
cgit v0.12


From 7f743eb32b2e6643b071cdd82b1110d77b3b1a99 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 24 Aug 2025 10:40:58 +0000
Subject: Tinkering, making code simpler or easier to maintain

---
 generic/tclOODefineCmds.c | 220 +++++++++++++++++++++++++---------------------
 generic/tclOOScript.h     |  22 ++---
 tools/tclOOScript.tcl     |  32 ++++---
 win/Makefile.in           |   2 +-
 4 files changed, 151 insertions(+), 125 deletions(-)

diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 0b1495a..e3fbe3f 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -1231,6 +1231,119 @@ MagicDefinitionInvoke(
 /*
  * ----------------------------------------------------------------------
  *
+ * ExportMethod, UnexportMethod, ExportInstanceMethod, UnexportInstanceMethod --
+ *
+ *	Exporting and unexporting are done by setting or removing the
+ *	PUBLIC_METHOD flag on the method record. If there is no such method in
+ *	this class or object (i.e. the method comes from something inherited
+ *	from or that we're an instance of) then we put in a blank record just
+ *	to hold that flag (or its absence); such records are skipped over by
+ *	the call chain engine *except* for their flags member.
+ *
+ *	Caller has the responsibility to update any epochs if necessary.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+// Make a blank method record or look up the existing one.
+static inline Method *
+GetOrCreateMethod(
+    Tcl_HashTable *tablePtr,
+    Tcl_Obj *namePtr,
+    int *isNew)
+{
+    Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(tablePtr, namePtr,
+		    isNew);
+    if (*isNew) {
+	Method *mPtr = (Method *) Tcl_Alloc(sizeof(Method));
+	memset(mPtr, 0, sizeof(Method));
+	mPtr->refCount = 1;
+	mPtr->namePtr = namePtr;
+	Tcl_IncrRefCount(namePtr);
+	Tcl_SetHashValue(hPtr, mPtr);
+	return mPtr;
+    } else {
+	return (Method *) Tcl_GetHashValue(hPtr);
+    }
+}
+
+static int
+ExportMethod(
+    Class *clsPtr,
+    Tcl_Obj *namePtr)
+{
+    int isNew;
+    Method *mPtr = GetOrCreateMethod(&clsPtr->classMethods, namePtr, &isNew);
+    if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) {
+	mPtr->flags |= PUBLIC_METHOD;
+	mPtr->flags &= ~TRUE_PRIVATE_METHOD;
+	isNew = 1;
+    }
+    return isNew;
+}
+
+static int
+UnexportMethod(
+    Class *clsPtr,
+    Tcl_Obj *namePtr)
+{
+    int isNew;
+    Method *mPtr = GetOrCreateMethod(&clsPtr->classMethods, namePtr, &isNew);
+    if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
+	mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
+	isNew = 1;
+    }
+    return isNew;
+}
+
+// Make the table of methods in the instance if it doesn't already exist.
+static inline void
+InitMethodTable(
+    Object *oPtr)
+{
+    if (!oPtr->methodsPtr) {
+	oPtr->methodsPtr = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable));
+	Tcl_InitObjHashTable(oPtr->methodsPtr);
+	oPtr->flags &= ~USE_CLASS_CACHE;
+    }
+}
+
+static int
+ExportInstanceMethod(
+    Object *oPtr,
+    Tcl_Obj *namePtr)
+{
+    InitMethodTable(oPtr);
+
+    int isNew;
+    Method *mPtr = GetOrCreateMethod(oPtr->methodsPtr, namePtr, &isNew);
+    if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) {
+	mPtr->flags |= PUBLIC_METHOD;
+	mPtr->flags &= ~TRUE_PRIVATE_METHOD;
+	isNew = 1;
+    }
+    return isNew;
+}
+
+static int
+UnexportInstanceMethod(
+    Object *oPtr,
+    Tcl_Obj *namePtr)
+{
+    InitMethodTable(oPtr);
+
+    int isNew;
+    Method *mPtr = GetOrCreateMethod(oPtr->methodsPtr, namePtr, &isNew);
+    if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
+	mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
+	isNew = 1;
+    }
+    return isNew;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * TclOODefineObjCmd --
  *
  *	Implementation of the "oo::define" command. Works by effectively doing
@@ -1939,22 +2052,18 @@ TclOODefineExportObjCmd(
     Tcl_Obj *const *objv)
 {
     int isInstanceExport = (clientData != NULL);
-    Object *oPtr;
-    Method *mPtr;
-    Tcl_HashEntry *hPtr;
-    Class *clsPtr;
-    int i, isNew, changed = 0;
+    int i, changed = 0;
 
     if (objc < 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
 	return TCL_ERROR;
     }
 
-    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
     if (oPtr == NULL) {
 	return TCL_ERROR;
     }
-    clsPtr = oPtr->classPtr;
+    Class *clsPtr = oPtr->classPtr;
     if (!isInstanceExport && !clsPtr) {
 	Tcl_SetObjResult(interp, Tcl_NewStringObj(
 		"attempt to misuse API", TCL_AUTO_LENGTH));
@@ -1973,33 +2082,9 @@ TclOODefineExportObjCmd(
 	 */
 
 	if (isInstanceExport) {
-	    if (!oPtr->methodsPtr) {
-		oPtr->methodsPtr = (Tcl_HashTable *)
-			Tcl_Alloc(sizeof(Tcl_HashTable));
-		Tcl_InitObjHashTable(oPtr->methodsPtr);
-		oPtr->flags &= ~USE_CLASS_CACHE;
-	    }
-	    hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, objv[i],
-		    &isNew);
-	} else {
-	    hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, objv[i],
-		    &isNew);
-	}
-
-	if (isNew) {
-	    mPtr = (Method *) Tcl_Alloc(sizeof(Method));
-	    memset(mPtr, 0, sizeof(Method));
-	    mPtr->refCount = 1;
-	    mPtr->namePtr = objv[i];
-	    Tcl_IncrRefCount(objv[i]);
-	    Tcl_SetHashValue(hPtr, mPtr);
+	    changed |= ExportInstanceMethod(oPtr, objv[i]);
 	} else {
-	    mPtr = (Method *) Tcl_GetHashValue(hPtr);
-	}
-	if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) {
-	    mPtr->flags |= PUBLIC_METHOD;
-	    mPtr->flags &= ~TRUE_PRIVATE_METHOD;
-	    changed = 1;
+	    changed |= ExportMethod(clsPtr, objv[i]);
 	}
     }
 
@@ -2350,75 +2435,6 @@ TclOODefineRenameMethodObjCmd(
 }
 
 /*
- * Unexporting is done by removing the PUBLIC_METHOD flag from the method
- * record. If there is no such method in this object or class (i.e. the method
- * comes from something inherited from or that we're an instance of) then we
- * put in a blank record without that flag; such records are skipped over by
- * the call chain engine *except* for their flags member.
- *
- * Caller has the responsibility to update any epochs if necessary.
- */
-
-static int
-UnexportMethod(
-    Class *clsPtr,
-    Tcl_Obj *namePtr)
-{
-    int isNew;
-    Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, namePtr,
-		    &isNew);
-    Method *mPtr;
-    if (isNew) {
-	mPtr = (Method *) Tcl_Alloc(sizeof(Method));
-	memset(mPtr, 0, sizeof(Method));
-	mPtr->refCount = 1;
-	mPtr->namePtr = namePtr;
-	Tcl_IncrRefCount(namePtr);
-	Tcl_SetHashValue(hPtr, mPtr);
-    } else {
-	mPtr = (Method *) Tcl_GetHashValue(hPtr);
-    }
-    if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
-	mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
-	isNew = 1;
-    }
-    return isNew;
-}
-
-static int
-UnexportInstanceMethod(
-    Object *oPtr,
-    Tcl_Obj *namePtr)
-{
-    if (!oPtr->methodsPtr) {
-	oPtr->methodsPtr = (Tcl_HashTable *)
-		Tcl_Alloc(sizeof(Tcl_HashTable));
-	Tcl_InitObjHashTable(oPtr->methodsPtr);
-	oPtr->flags &= ~USE_CLASS_CACHE;
-    }
-
-    int isNew;
-    Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, namePtr,
-	    &isNew);
-    Method *mPtr;
-    if (isNew) {
-	mPtr = (Method *) Tcl_Alloc(sizeof(Method));
-	memset(mPtr, 0, sizeof(Method));
-	mPtr->refCount = 1;
-	mPtr->namePtr = namePtr;
-	Tcl_IncrRefCount(namePtr);
-	Tcl_SetHashValue(hPtr, mPtr);
-    } else {
-	mPtr = (Method *) Tcl_GetHashValue(hPtr);
-    }
-    if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
-	mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
-	isNew = 1;
-    }
-    return isNew;
-}
-
-/*
  * ----------------------------------------------------------------------
  *
  * TclOODefineUnexportObjCmd --
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 4c5f1a2..390b034 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -72,24 +72,24 @@ static const char *tclOOSetupScript =
 "\t}\n"
 "\tclass create singleton\n"
 "\tdefine singleton superclass -set class\n"
-"\tdefine singleton variable -set object\n"
 "\tdefine singleton unexport create createWithNamespace\n"
 "\tdefine singleton method new args {\n"
+"\t\tvariable object\n"
 "\t\tif {![info exists object] || ![info object isa object $object]} {\n"
 "\t\t\tset object [next {*}$args]\n"
-"\t\t\t::oo::objdefine $object {\n"
-"\t\t\t\tmethod destroy {} {\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\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"
+"\t\t\t::oo::objdefine $object mixin -prepend ::oo::SingletonInstance\n"
 "\t\t}\n"
 "\t\treturn $object\n"
 "\t}\n"
+"\tclass create SingletonInstance\n"
+"\tdefine SingletonInstance method destroy {} {\n"
+"\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n"
+"\t\t\t\"may not destroy a singleton object\"\n"
+"\t}\n"
+"\tdefine SingletonInstance method <cloned> -unexport {originObject} {\n"
+"\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n"
+"\t\t\t\"may not clone a singleton object\"\n"
+"\t}\n"
 "\tclass create abstract\n"
 "\tdefine abstract superclass -set class\n"
 "\tdefine abstract unexport create createWithNamespace new\n"
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 6b17483..b17d7d0 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -92,27 +92,37 @@
 
     class create singleton
     define singleton superclass -set class
-    define singleton variable -set object
     define singleton unexport create createWithNamespace
     define singleton method new args {
+	variable object
 	if {![info exists object] || ![info object isa object $object]} {
 	    set object [next {*}$args]
-	    ::oo::objdefine $object {
-		method destroy {} {
-		    return -code error -errorcode {TCL OO SINGLETON} \
-			"may not destroy a singleton object"
-		}
-		method <cloned> -unexport {originObject} {
-		    return -code error -errorcode {TCL OO SINGLETON} \
-			"may not clone a singleton object"
-		}
-	    }
+	    ::oo::objdefine $object mixin -prepend ::oo::SingletonInstance
 	}
 	return $object
     }
 
     # ----------------------------------------------------------------------
     #
+    # oo::SingletonInstance --
+    #
+    #	A mixin used to make an object so it won't be destroyed or cloned (or
+    #	at least not easily).
+    #
+    # ----------------------------------------------------------------------
+
+    class create SingletonInstance
+    define SingletonInstance method destroy {} {
+	return -code error -errorcode {TCL OO SINGLETON} \
+	    "may not destroy a singleton object"
+    }
+    define SingletonInstance method <cloned> -unexport {originObject} {
+	return -code error -errorcode {TCL OO SINGLETON} \
+	    "may not clone a singleton object"
+    }
+
+    # ----------------------------------------------------------------------
+    #
     # oo::abstract --
     #
     #	A metaclass that is used to make classes that can't be directly
diff --git a/win/Makefile.in b/win/Makefile.in
index 5457bcb..d0e264a 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -758,7 +758,7 @@ tclWinPanic.${OBJEXT}: tclWinPanic.c
 .rc.$(RES):
 	$(RC) @RC_OUT@ $@ @RC_TYPE@ @RC_DEFINES@ @RC_INCLUDE@ "$(GENERIC_DIR_NATIVE)" @RC_INCLUDE@ "$(WIN_DIR_NATIVE)" @DEPARG@
 
-
+tclOO.${OBJEXT}: tclOO.c tclOOScript.h
 
 #--------------------------------------------------------------------------
 # Minizip implementation
-- 
cgit v0.12


From a95bde48906c8729d4d76c10bfd700439c2c7196 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Mon, 25 Aug 2025 09:37:02 +0000
Subject: Fix testcase oo-1.21

---
 tests/oo.test | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/tests/oo.test b/tests/oo.test
index 21c8f9e..7d5ea37 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -390,7 +390,7 @@ test oo-1.21 {basic test of OO functionality: default relations} -setup {
     }] {lsort [lsearch -all -not -inline $x *::delegate]}
 } -cleanup {
     interp delete $fresh
-} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::configurable ::oo::configuresupport::configurable ::oo::object ::oo::singleton} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class ::oo::configuresupport::configurable} {::oo::abstract ::oo::configurable ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}
+} -result {{} {::oo::SingletonInstance ::oo::Slot ::oo::abstract ::oo::class ::oo::configurable ::oo::configuresupport::configurable ::oo::object ::oo::singleton} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::SingletonInstance ::oo::Slot ::oo::class ::oo::configuresupport::configurable} {::oo::abstract ::oo::configurable ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}
 test oo-1.22 {basic test of OO functionality: nested ownership destruction order} -setup {
     oo::class create parent
 } -body {
-- 
cgit v0.12