diff options
Diffstat (limited to 'generic')
-rw-r--r-- | generic/tclCmdIL.c | 2 | ||||
-rw-r--r-- | generic/tclCompCmds.c | 97 | ||||
-rw-r--r-- | generic/tclInt.h | 3 |
3 files changed, 96 insertions, 6 deletions
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 14e9f0e..7be017d 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -164,7 +164,7 @@ static const EnsembleImplMap defaultInfoMap[] = { {"args", InfoArgsCmd, NULL, NULL, NULL, 0}, {"body", InfoBodyCmd, NULL, NULL, NULL, 0}, {"cmdcount", InfoCmdCountCmd, NULL, NULL, NULL, 0}, - {"commands", InfoCommandsCmd, NULL, NULL, NULL, 0}, + {"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0}, {"complete", InfoCompleteCmd, NULL, NULL, NULL, 0}, {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0}, {"default", InfoDefaultCmd, NULL, NULL, NULL, 0}, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 245779e..79b2709 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -3038,6 +3038,64 @@ TclCompileIncrCmd( */ int +TclCompileInfoCommandsCmd( + 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) +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + Tcl_Obj *objPtr; + char *bytes; + + /* + * We require one compile-time known argument for the case we can compile. + */ + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + objPtr = Tcl_NewObj(); + Tcl_IncrRefCount(objPtr); + if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { + goto notCompilable; + } + bytes = Tcl_GetString(objPtr); + + /* + * We require that the argument start with "::" and not have any of "*\[?" + * in it. (Theoretically, we should look in only the final component, but + * the difference is so slight given current naming practices.) + */ + + if (bytes[0] != ':' || bytes[1] != ':' || !TclMatchIsTrivial(bytes)) { + goto notCompilable; + } + Tcl_DecrRefCount(objPtr); + + /* + * Confirmed as a literal that will not frighten the horses. Compile. Note + * that the result needs to be list-ified. + */ + + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_STR_LEN, envPtr); + TclEmitInstInt1( INST_JUMP_FALSE1, 7, envPtr); + TclEmitInstInt4( INST_LIST, 1, envPtr); + return TCL_OK; + + notCompilable: + Tcl_DecrRefCount(objPtr); + return TCL_ERROR; +} + +int TclCompileInfoCoroutineCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command @@ -4859,23 +4917,52 @@ TclCompileObjectSelfCmd( * bytecoding is at all reasonable. */ - if (parsePtr->numWords > 2) { - return TCL_ERROR; + if (parsePtr->numWords == 1) { + goto compileSelfObject; } else if (parsePtr->numWords == 2) { - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr), *subcmd; - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0 || - strncmp(tokenPtr[1].start, "object", tokenPtr[1].size) != 0) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0) { return TCL_ERROR; } + + subcmd = tokenPtr + 1; + if (strncmp(subcmd->start, "object", subcmd->size) == 0) { + goto compileSelfObject; + } else if (strncmp(subcmd->start, "namespace", subcmd->size) == 0) { + goto compileSelfNamespace; + } } /* + * Can't compile; handle with runtime call. + */ + + return TCL_ERROR; + + compileSelfObject: + + /* * This delegates the entire problem to a single opcode. */ TclEmitOpcode( INST_TCLOO_SELF, envPtr); return TCL_OK; + + compileSelfNamespace: + + /* + * This is formally only correct with TclOO methods as they are currently + * implemented; it assumes that the current namespace is invariably when a + * TclOO context is present is the object's namespace, and that's + * technically only something that's a matter of current policy. But it + * avoids creating another opcode, so that's all good! + */ + + TclEmitOpcode( INST_TCLOO_SELF, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitOpcode( INST_NS_CURRENT, envPtr); + return TCL_OK; } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 865378e..7182c05 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3550,6 +3550,9 @@ MODULE_SCOPE int TclCompileGlobalCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileIfCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoCommandsCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileInfoCoroutineCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); |