From 8c9ab6bacf51046f3bb722ac655d9a3ddfd237d2 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 25 Oct 2012 09:56:35 +0000
Subject: Added compilation of [namespace code] (except for gnarly edge cases).

---
 generic/tclCompCmds.c | 50 ++++++++++++++++++++++++++++++++++++++++++++++++++
 generic/tclInt.h      |  3 +++
 generic/tclNamesp.c   |  2 +-
 3 files changed, 54 insertions(+), 1 deletion(-)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index bba5384..66bc5f0 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -4040,6 +4040,56 @@ TclCompileNamespaceCurrentCmd(
 }
 
 int
+TclCompileNamespaceCodeCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
+				 * created by Tcl_ParseCommand. */
+    Command *cmdPtr,		/* Points to defintion of command being
+				 * compiled. */
+    CompileEnv *envPtr)		/* Holds resulting instructions. */
+{
+    Tcl_Token *tokenPtr;
+    DefineLineInformation;	/* TIP #280 */
+
+    if (parsePtr->numWords != 2) {
+	return TCL_ERROR;
+    }
+    tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+    /*
+     * The specification of [namespace code] is rather shocking, in that it is
+     * supposed to check if the argument is itself the result of [namespace
+     * code] and not apply itself in that case. Which is excessively cautious,
+     * but what the test suite checks for.
+     */
+
+    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || (tokenPtr[1].size > 20
+	    && strncmp(tokenPtr[1].start, "::namespace inscope ", 20) == 0)) {
+	/*
+	 * Technically, we could just pass a literal '::namespace inscope '
+	 * term through, but that's something which really shouldn't be
+	 * occurring as something that the user writes so we'll just punt it.
+	 */
+
+	return TCL_ERROR;
+    }
+
+    /*
+     * Now we can compile using the same strategy as [namespace code]'s normal
+     * implementation does internally. Note that we can't bind the namespace
+     * name directly here, because TclOO plays complex games with namespaces;
+     * the value needs to be determined at runtime for safety.
+     */
+
+    PushLiteral(envPtr,		"::namespace",		11);
+    PushLiteral(envPtr,		"inscope",		7);
+    TclEmitOpcode(		INST_NS_CURRENT,	envPtr);
+    CompileWord(envPtr,		tokenPtr,		interp, 1);
+    TclEmitInstInt4(		INST_LIST, 4,		envPtr);
+    return TCL_OK;
+}
+
+int
 TclCompileNamespaceUpvarCmd(
     Tcl_Interp *interp,		/* Used for error reporting. */
     Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 02c8a35..1bf52d1 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3588,6 +3588,9 @@ MODULE_SCOPE int	TclCompileLreplaceCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileLsetCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileNamespaceCodeCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileNamespaceCurrentCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index d98de97..072eb72 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -161,7 +161,7 @@ static const Tcl_ObjType nsNameType = {
 
 static const EnsembleImplMap defaultNamespaceMap[] = {
     {"children",	NamespaceChildrenCmd, NULL, NULL, NULL, 0},
-    {"code",		NamespaceCodeCmd, NULL, NULL, NULL, 0},
+    {"code",		NamespaceCodeCmd,	TclCompileNamespaceCodeCmd, NULL, NULL, 0},
     {"current",		NamespaceCurrentCmd,	TclCompileNamespaceCurrentCmd, NULL, NULL, 0},
     {"delete",		NamespaceDeleteCmd, NULL, NULL, NULL, 0},
     {"ensemble",	TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0},
-- 
cgit v0.12