From 58467a7afe9d9eb62bb1da4d29690223a3681c16 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Mon, 19 Sep 2022 08:31:49 +0000
Subject: New (internal) function TclGetObjInterpProc2() and macro
 TclObjInterpProc2. Will be needed for Itcl (in combination with TIP #626).
 Should have been part of TIP #627.

---
 generic/tclInt.decls  |  3 +++
 generic/tclIntDecls.h |  9 ++++++---
 generic/tclProc.c     | 53 ++++++++++++++++++++++++++++++++++++++++++++++-----
 generic/tclStubInit.c |  2 +-
 4 files changed, 58 insertions(+), 9 deletions(-)

diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 08d35e1..d16a74c 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -116,6 +116,9 @@ declare 41 {
 declare 42 {
     const char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr)
 }
+declare 43 {
+    Tcl_ObjCmdProc2 *TclGetObjInterpProc2(void)
+}
 declare 44 {
     int TclGuessPackageName(const char *fileName, Tcl_DString *bufPtr)
 }
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 588a1fa..ec9023f 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -155,7 +155,8 @@ EXTERN Tcl_Command	TclGetOriginalCommand(Tcl_Command command);
 /* 42 */
 EXTERN const char *	TclpGetUserHome(const char *name,
 				Tcl_DString *bufferPtr);
-/* Slot 43 is reserved */
+/* 43 */
+EXTERN Tcl_ObjCmdProc2 * TclGetObjInterpProc2(void);
 /* 44 */
 EXTERN int		TclGuessPackageName(const char *fileName,
 				Tcl_DString *bufPtr);
@@ -711,7 +712,7 @@ typedef struct TclIntStubs {
     int (*tclGetOpenMode) (Tcl_Interp *interp, const char *str, int *seekFlagPtr); /* 40 */
     Tcl_Command (*tclGetOriginalCommand) (Tcl_Command command); /* 41 */
     const char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */
-    void (*reserved43)(void);
+    Tcl_ObjCmdProc2 * (*tclGetObjInterpProc2) (void); /* 43 */
     int (*tclGuessPackageName) (const char *fileName, Tcl_DString *bufPtr); /* 44 */
     int (*tclHideUnsafeCommands) (Tcl_Interp *interp); /* 45 */
     int (*tclInExit) (void); /* 46 */
@@ -1012,7 +1013,8 @@ extern const TclIntStubs *tclIntStubsPtr;
 	(tclIntStubsPtr->tclGetOriginalCommand) /* 41 */
 #define TclpGetUserHome \
 	(tclIntStubsPtr->tclpGetUserHome) /* 42 */
-/* Slot 43 is reserved */
+#define TclGetObjInterpProc2 \
+	(tclIntStubsPtr->tclGetObjInterpProc2) /* 43 */
 #define TclGuessPackageName \
 	(tclIntStubsPtr->tclGuessPackageName) /* 44 */
 #define TclHideUnsafeCommands \
@@ -1420,6 +1422,7 @@ extern const TclIntStubs *tclIntStubsPtr;
 #undef TclSetPreInitScript
 #undef TclObjInterpProc
 #define TclObjInterpProc TclGetObjInterpProc()
+#define TclObjInterpProc2 TclGetObjInterpProc2()
 #ifndef TCL_NO_DEPRECATED
 #   define TclSetPreInitScript Tcl_SetPreInitScript
 #   define TclGuessPackageName(fileName, pkgName) ((void)fileName,(void)pkgName,0)
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 059e751..f826a14 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -1682,6 +1682,43 @@ TclNRInterpProc(
     }
     return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
 }
+
+static int
+NRInterpProc2(
+    ClientData clientData,	/* Record describing procedure to be
+				 * interpreted. */
+    Tcl_Interp *interp,/* Interpreter in which procedure was
+				 * invoked. */
+    size_t objc,			/* Count of number of arguments to this
+				 * procedure. */
+    Tcl_Obj *const objv[])	/* Argument value objects. */
+{
+    int result = TclPushProcCallFrame(clientData, interp, objc, objv,
+	    /*isLambda*/ 0);
+
+    if (result != TCL_OK) {
+	return TCL_ERROR;
+    }
+    return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
+}
+
+static int
+ObjInterpProc2(
+    ClientData clientData,	/* Record describing procedure to be
+				 * interpreted. */
+    Tcl_Interp *interp,/* Interpreter in which procedure was
+				 * invoked. */
+    size_t objc,			/* Count of number of arguments to this
+				 * procedure. */
+    Tcl_Obj *const objv[])	/* Argument value objects. */
+{
+    /*
+     * Not used much in the core; external interface for iTcl
+     */
+
+    return Tcl_NRCallObjProc2(interp, NRInterpProc2, clientData, objc, objv);
+}
+
 
 /*
  *----------------------------------------------------------------------
@@ -2273,12 +2310,12 @@ TclUpdateReturnInfo(
 /*
  *----------------------------------------------------------------------
  *
- * TclGetObjInterpProc --
+ * TclGetObjInterpProc/TclGetObjInterpProc2 --
  *
- *	Returns a pointer to the TclObjInterpProc function; this is different
- *	from the value obtained from the TclObjInterpProc reference on systems
- *	like Windows where import and export versions of a function exported
- *	by a DLL exist.
+ *	Returns a pointer to the TclObjInterpProc/ObjInterpProc2 functions;
+ *	this is different from the value obtained from the TclObjInterpProc
+ *	reference on systems like Windows where import and export versions
+ *	of a function exported by a DLL exist.
  *
  * Results:
  *	Returns the internal address of the TclObjInterpProc function.
@@ -2294,6 +2331,12 @@ TclGetObjInterpProc(void)
 {
     return TclObjInterpProc;
 }
+
+Tcl_ObjCmdProc2 *
+TclGetObjInterpProc2(void)
+{
+    return ObjInterpProc2;
+}
 
 /*
  *----------------------------------------------------------------------
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index ae00b04..2abd2fb 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -903,7 +903,7 @@ static const TclIntStubs tclIntStubs = {
     TclGetOpenMode, /* 40 */
     TclGetOriginalCommand, /* 41 */
     TclpGetUserHome, /* 42 */
-    0, /* 43 */
+    TclGetObjInterpProc2, /* 43 */
     TclGuessPackageName, /* 44 */
     TclHideUnsafeCommands, /* 45 */
     TclInExit, /* 46 */
-- 
cgit v0.12