summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--generic/tclCompCmds.c50
-rw-r--r--generic/tclInt.h3
-rw-r--r--generic/tclNamesp.c2
3 files changed, 54 insertions, 1 deletions
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},