summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclAssembly.c4
-rw-r--r--generic/tclCompCmds.c46
-rw-r--r--generic/tclCompile.c5
-rw-r--r--generic/tclCompile.h5
-rw-r--r--generic/tclExecute.c10
-rw-r--r--generic/tclInt.h3
-rw-r--r--generic/tclNamesp.c2
7 files changed, 71 insertions, 4 deletions
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 132ee68..27720c7 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -461,6 +461,7 @@ static const TalInstDesc TalInstructionTable[] = {
0, 1},
{"pushResult", ASSEM_1BYTE, INST_PUSH_RESULT, 0, 1},
{"regexp", ASSEM_REGEXP, INST_REGEXP, 2, 1},
+ {"resolveCmd", ASSEM_1BYTE, INST_RESOLVE_COMMAND, 1, 1},
{"reverse", ASSEM_REVERSE, INST_REVERSE, INT_MIN,-1-0},
{"rshift", ASSEM_1BYTE, INST_RSHIFT, 2, 1},
{"store", ASSEM_LVT, (INST_STORE_SCALAR1<<8
@@ -507,7 +508,8 @@ static const unsigned char NonThrowingByteCodes[] = {
INST_NOP, /* 132 */
INST_NS_CURRENT, /* 141 */
INST_COROUTINE_NAME, /* 142 */
- INST_INFO_LEVEL_NUM /* 143 */
+ INST_INFO_LEVEL_NUM, /* 143 */
+ INST_RESOLVE_COMMAND /* 145 */
};
/*
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 66bc5f0..245779e 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -4151,6 +4151,52 @@ TclCompileNamespaceUpvarCmd(
PushLiteral(envPtr, "", 0);
return TCL_OK;
}
+
+int
+TclCompileNamespaceWhichCmd(
+ 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. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr, *opt;
+ int idx;
+
+ if (parsePtr->numWords < 2 || parsePtr->numWords > 3) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ idx = 1;
+
+ /*
+ * If there's an option, check that it's "-command". We don't handle
+ * "-variable" (currently) and anything else is an error.
+ */
+
+ if (parsePtr->numWords == 3) {
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ opt = tokenPtr + 1;
+ if (opt->size < 2 || opt->size > 8
+ || strncmp(opt->start, "-command", opt->size) != 0) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ idx++;
+ }
+
+ /*
+ * Issue the bytecode.
+ */
+
+ CompileWord(envPtr, tokenPtr, interp, idx);
+ TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr);
+ return TCL_OK;
+}
/*
*----------------------------------------------------------------------
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 3ee0fdf..b331551 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -448,6 +448,11 @@ InstructionDesc const tclInstructionTable[] = {
/* Push the argument words to a stack depth (i.e., [info level <n>])
* of the interpreter as an object on the stack.
* Stack: ... depth => ... argList */
+ {"resolveCmd", 1, 0, 0, {OPERAND_NONE}},
+ /* Resolves the command named on the top of the stack to its fully
+ * qualified version, or produces the empty string if no such command
+ * exists. Never generates errors.
+ * Stack: ... cmdName => ... fullCmdName */
{"tclooSelf", 1, +1, 0, {OPERAND_NONE}},
/* Push the identity of the current TclOO object (i.e., the name of
* its current public access command) on the stack. */
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 044bef9..86a0f77 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -686,10 +686,11 @@ typedef struct ByteCode {
#define INST_COROUTINE_NAME 142
#define INST_INFO_LEVEL_NUM 143
#define INST_INFO_LEVEL_ARGS 144
-#define INST_TCLOO_SELF 145
+#define INST_RESOLVE_COMMAND 145
+#define INST_TCLOO_SELF 146
/* The last opcode */
-#define LAST_INST_OPCODE 145
+#define LAST_INST_OPCODE 146
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 0ec16e9..a24c806 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4107,6 +4107,16 @@ TEBCresume(
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
}
+ case INST_RESOLVE_COMMAND: {
+ Tcl_Command cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS);
+
+ TclNewObj(objResultPtr);
+ if (cmd != NULL) {
+ Tcl_GetCommandFullName(interp, cmd, objResultPtr);
+ }
+ TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr);
+ NEXT_INST_F(1, 1, 1);
+ }
case INST_TCLOO_SELF: {
CallFrame *framePtr = iPtr->varFramePtr;
CallContext *contextPtr;
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 1bf52d1..448a7cd 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3597,6 +3597,9 @@ MODULE_SCOPE int TclCompileNamespaceCurrentCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileNamespaceUpvarCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileNamespaceWhichCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 072eb72..60c40d0 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -178,7 +178,7 @@ static const EnsembleImplMap defaultNamespaceMap[] = {
{"tail", NamespaceTailCmd, NULL, NULL, NULL, 0},
{"unknown", NamespaceUnknownCmd, NULL, NULL, NULL, 0},
{"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0},
- {"which", NamespaceWhichCmd, NULL, NULL, NULL, 0},
+ {"which", NamespaceWhichCmd, TclCompileNamespaceWhichCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
generated by cgit v0.12 at 2024-11-02 18:53:17 (GMT)