summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclAssembly.c13
-rw-r--r--generic/tclBasic.c15
-rw-r--r--generic/tclCmdIL.c6
-rw-r--r--generic/tclCompCmds.c319
-rw-r--r--generic/tclCompCmdsSZ.c43
-rw-r--r--generic/tclCompile.c35
-rw-r--r--generic/tclCompile.h13
-rw-r--r--generic/tclExecute.c140
-rw-r--r--generic/tclInt.h25
-rw-r--r--generic/tclNamesp.c275
-rw-r--r--generic/tclOO.c6
-rw-r--r--tests/info.test6
12 files changed, 731 insertions, 165 deletions
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 83f4fe9..5ff96fd 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -369,6 +369,8 @@ static const TalInstDesc TalInstructionTable[] = {
{"bitor", ASSEM_1BYTE, INST_BITOR, 2, 1},
{"bitxor", ASSEM_1BYTE, INST_BITXOR, 2, 1},
{"concat", ASSEM_CONCAT1, INST_CONCAT1, INT_MIN,1},
+ {"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1},
+ {"currentNamespace",ASSEM_1BYTE, INST_NS_CURRENT, 0, 1},
{"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1},
{"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 1},
{"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1},
@@ -406,6 +408,8 @@ static const TalInstDesc TalInstructionTable[] = {
{"incrStk", ASSEM_1BYTE, INST_INCR_SCALAR_STK, 2, 1},
{"incrStkImm", ASSEM_SINT1, INST_INCR_SCALAR_STK_IMM,
1, 1},
+ {"infoLevelArgs", ASSEM_1BYTE, INST_INFO_LEVEL_ARGS, 1, 1},
+ {"infoLevelNumber", ASSEM_1BYTE, INST_INFO_LEVEL_NUM, 0, 1},
{"invokeStk", ASSEM_INVOKE, (INST_INVOKE_STK1 << 8
| INST_INVOKE_STK4), INT_MIN,1},
{"jump", ASSEM_JUMP, INST_JUMP1, 0, 0},
@@ -457,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
@@ -472,6 +477,7 @@ static const TalInstDesc TalInstructionTable[] = {
{"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1},
{"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1},
{"sub", ASSEM_1BYTE, INST_SUB, 2, 1},
+ {"tclooSelf", ASSEM_1BYTE, INST_TCLOO_SELF, 0, 1},
{"tryCvtToNumeric", ASSEM_1BYTE, INST_TRY_CVT_TO_NUMERIC,1, 1},
{"uminus", ASSEM_1BYTE, INST_UMINUS, 1, 1},
{"unset", ASSEM_BOOL_LVT4,INST_UNSET_SCALAR, 0, 0},
@@ -481,6 +487,7 @@ static const TalInstDesc TalInstructionTable[] = {
{"uplus", ASSEM_1BYTE, INST_UPLUS, 1, 1},
{"upvar", ASSEM_LVT4, INST_UPVAR, 2, 1},
{"variable", ASSEM_LVT4, INST_VARIABLE, 1, 0},
+ {"yield", ASSEM_1BYTE, INST_YIELD, 1, 1},
{NULL, 0, 0, 0, 0}
};
@@ -499,7 +506,11 @@ static const unsigned char NonThrowingByteCodes[] = {
INST_OVER, /* 95 */
INST_PUSH_RETURN_OPTIONS, /* 108 */
INST_REVERSE, /* 126 */
- INST_NOP /* 132 */
+ INST_NOP, /* 132 */
+ INST_COROUTINE_NAME, /* 142 */
+ INST_NS_CURRENT, /* 143 */
+ INST_INFO_LEVEL_NUM, /* 144 */
+ INST_RESOLVE_COMMAND /* 146 */
};
/*
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 3848d5b..ab087e6 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -131,7 +131,6 @@ static Tcl_Obj * GetCommandSource(Interp *iPtr, int objc,
Tcl_Obj *const objv[], int lookup);
static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected,
int actual, Tcl_Obj *const *objv);
-static Tcl_NRPostProc NRCoroutineActivateCallback;
static Tcl_NRPostProc NRCoroutineCallerCallback;
static Tcl_NRPostProc NRCoroutineExitCallback;
static int NRCommand(ClientData data[], Tcl_Interp *interp, int result);
@@ -258,7 +257,7 @@ static const CmdInfo builtInCmds[] = {
{"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, 1},
{"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, 1},
{"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, 1},
- {"yield", NULL, NULL, TclNRYieldObjCmd, 1},
+ {"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, 1},
{"yieldto", NULL, NULL, TclNRYieldToObjCmd, 1},
/*
@@ -8495,7 +8494,7 @@ TclNRYieldObjCmd(
}
NRE_ASSERT(!COR_IS_SUSPENDED(corPtr));
- TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr,
+ TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
clientData, NULL, NULL);
return TCL_OK;
}
@@ -8712,7 +8711,7 @@ NRCoroutineExitCallback(
/*
*----------------------------------------------------------------------
*
- * NRCoroutineActivateCallback --
+ * TclNRCoroutineActivateCallback --
*
* This is the workhorse for coroutines: it implements both yield and
* resume.
@@ -8726,8 +8725,8 @@ NRCoroutineExitCallback(
*----------------------------------------------------------------------
*/
-static int
-NRCoroutineActivateCallback(
+int
+TclNRCoroutineActivateCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
@@ -8902,7 +8901,7 @@ TclNRInterpCoroutine(
break;
}
- TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr,
+ TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
NULL, NULL, NULL);
return TCL_OK;
}
@@ -9059,7 +9058,7 @@ TclNRCoroutineObjCmd(
* Now just resume the coroutine.
*/
- TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr,
+ TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
NULL, NULL, NULL);
return TCL_OK;
}
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 14e0092..7be017d 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -164,9 +164,9 @@ 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, NULL, NULL, NULL, 0},
+ {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0},
{"default", InfoDefaultCmd, NULL, NULL, NULL, 0},
{"errorstack", InfoErrorStackCmd, NULL, NULL, NULL, 0},
{"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd, NULL, NULL, 0},
@@ -174,7 +174,7 @@ static const EnsembleImplMap defaultInfoMap[] = {
{"functions", InfoFunctionsCmd, NULL, NULL, NULL, 0},
{"globals", TclInfoGlobalsCmd, NULL, NULL, NULL, 0},
{"hostname", InfoHostnameCmd, NULL, NULL, NULL, 0},
- {"level", InfoLevelCmd, NULL, NULL, NULL, 0},
+ {"level", InfoLevelCmd, TclCompileInfoLevelCmd, NULL, NULL, 0},
{"library", InfoLibraryCmd, NULL, NULL, NULL, 0},
{"loaded", InfoLoadedCmd, NULL, NULL, NULL, 0},
{"locals", TclInfoLocalsCmd, NULL, NULL, NULL, 0},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index fc60016..79b2709 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -3022,22 +3022,105 @@ TclCompileIncrCmd(
/*
*----------------------------------------------------------------------
*
- * TclCompileInfoExistsCmd --
+ * TclCompileInfo*Cmd --
*
- * Procedure called to compile the "info exists" subcommand.
+ * Procedures called to compile "info" subcommands.
*
* Results:
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
* evaluation to runtime.
*
* Side effects:
- * Instructions are added to envPtr to execute the "info exists"
- * subcommand at runtime.
+ * Instructions are added to envPtr to execute the "info" subcommand at
+ * runtime.
*
*----------------------------------------------------------------------
*/
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
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Only compile [info coroutine] without arguments.
+ */
+
+ if (parsePtr->numWords != 1) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Not much to do; we compile to a single instruction...
+ */
+
+ TclEmitOpcode( INST_COROUTINE_NAME, envPtr);
+ return TCL_OK;
+}
+
+int
TclCompileInfoExistsCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
@@ -3088,6 +3171,42 @@ TclCompileInfoExistsCmd(
return TCL_OK;
}
+
+int
+TclCompileInfoLevelCmd(
+ 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. */
+{
+ /*
+ * Only compile [info level] without arguments or with a single argument.
+ */
+
+ if (parsePtr->numWords == 1) {
+ /*
+ * Not much to do; we compile to a single instruction...
+ */
+
+ TclEmitOpcode( INST_INFO_LEVEL_NUM, envPtr);
+ } else if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ } else {
+ DefineLineInformation; /* TIP #280 */
+
+ /*
+ * Compile the argument, then add the instruction to convert it into a
+ * list of arguments.
+ */
+
+ SetLineInformation(1);
+ CompileTokens(envPtr, TokenAfter(parsePtr->tokenPtr), interp);
+ TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr);
+ }
+ return TCL_OK;
+}
/*
*----------------------------------------------------------------------
@@ -3936,11 +4055,11 @@ TclCompileLmapCmd(
/*
*----------------------------------------------------------------------
*
- * TclCompileNamespaceCmd --
+ * TclCompileNamespace*Cmd --
*
- * Procedure called to compile the "namespace" command; currently, only
- * the subcommand "namespace upvar" is compiled to bytecodes, and then
- * only inside a procedure(-like) context.
+ * Procedures called to compile the "namespace" command; currently, only
+ * the subcommands "namespace current" and "namespace upvar" are compiled
+ * to bytecodes, and the latter only inside a procedure(-like) context.
*
* Results:
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
@@ -3954,6 +4073,81 @@ TclCompileLmapCmd(
*/
int
+TclCompileNamespaceCurrentCmd(
+ 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. */
+{
+ /*
+ * Only compile [namespace current] without arguments.
+ */
+
+ if (parsePtr->numWords != 1) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Not much to do; we compile to a single instruction...
+ */
+
+ TclEmitOpcode( INST_NS_CURRENT, envPtr);
+ return TCL_OK;
+}
+
+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
@@ -4015,6 +4209,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;
+}
/*
*----------------------------------------------------------------------
@@ -4662,6 +4902,69 @@ IndexTailVarIfKnown(
return localIndex;
}
+int
+TclCompileObjectSelfCmd(
+ 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. */
+{
+ /*
+ * We only handle [self] and [self object] (which is the same operation).
+ * These are the only very common operations on [self] for which
+ * bytecoding is at all reasonable.
+ */
+
+ if (parsePtr->numWords == 1) {
+ goto compileSelfObject;
+ } else if (parsePtr->numWords == 2) {
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr), *subcmd;
+
+ 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/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 8ed3a95..d7dd58e 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -2752,6 +2752,49 @@ TclCompileWhileCmd(
/*
*----------------------------------------------------------------------
*
+ * TclCompileYieldCmd --
+ *
+ * Procedure called to compile the "yield" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "yield" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileYieldCmd(
+ 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. */
+{
+ if (parsePtr->numWords < 1 || parsePtr->numWords > 2) {
+ return TCL_ERROR;
+ }
+
+ if (parsePtr->numWords == 1) {
+ PushLiteral(envPtr, "", 0);
+ } else {
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ CompileWord(envPtr, valueTokenPtr, interp, 1);
+ }
+ TclEmitOpcode(INST_YIELD, envPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* PushVarName --
*
* Procedure used in the compiling where pushing a variable name is
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index d4ca284..1924334 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -37,7 +37,7 @@ TCL_DECLARE_MUTEX(tableMutex)
int tclTraceCompile = 0;
static int traceInitialized = 0;
#endif
-
+
/*
* A table describing the Tcl bytecode instructions. Entries in this table
* must correspond to the instruction opcode definitions in tclCompile.h. The
@@ -435,6 +435,34 @@ InstructionDesc const tclInstructionTable[] = {
* indicated by the LVT index. Part of [dict with].
* Stack: ... path keyList => ... */
+ {"yield", 1, 0, 0, {OPERAND_NONE}},
+ /* Makes the current coroutine yield the value at the top of the
+ * stack, and places the response back on top of the stack when it
+ * resumes.
+ * Stack: ... valueToYield => ... resumeValue */
+ {"coroName", 1, +1, 0, {OPERAND_NONE}},
+ /* Push the name of the interpreter's current coroutine as an object
+ * on the stack. */
+
+ {"currentNamespace", 1, +1, 0, {OPERAND_NONE}},
+ /* Push the name of the interpreter's current namespace as an object
+ * on the stack. */
+ {"infoLevelNumber", 1, +1, 0, {OPERAND_NONE}},
+ /* Push the stack depth (i.e., [info level]) of the interpreter as an
+ * object on the stack. */
+ {"infoLevelArgs", 1, 0, 0, {OPERAND_NONE}},
+ /* 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. */
+
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
@@ -1673,10 +1701,10 @@ TclCompileScript(
&& !(cmdPtr->nsPtr->flags&NS_SUPPRESS_COMPILATION)
&& !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)
&& !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
- int savedNumCmds = envPtr->numCommands;
+ int code, savedNumCmds = envPtr->numCommands;
unsigned savedCodeNext =
envPtr->codeNext - envPtr->codeStart;
- int update = 0, code;
+ int update = 0;
/*
* Mark the start of the command; the proper bytecode
@@ -4620,6 +4648,5 @@ RecordByteCodeStats(
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
- * indent-tabs-mode: nil
* End:
*/
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index ba78c36..fcff46c 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -681,8 +681,19 @@ typedef struct ByteCode {
#define INST_DICT_RECOMBINE_STK 139
#define INST_DICT_RECOMBINE_IMM 140
+/* For operations to do with coroutines */
+#define INST_YIELD 141
+#define INST_COROUTINE_NAME 142
+
+/* For compilation of basic information operations */
+#define INST_NS_CURRENT 143
+#define INST_INFO_LEVEL_NUM 144
+#define INST_INFO_LEVEL_ARGS 145
+#define INST_RESOLVE_COMMAND 146
+#define INST_TCLOO_SELF 147
+
/* The last opcode */
-#define LAST_INST_OPCODE 140
+#define LAST_INST_OPCODE 147
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 3c0b472..b42e4ab 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -17,6 +17,7 @@
#include "tclInt.h"
#include "tclCompile.h"
+#include "tclOOInt.h"
#include "tommath.h"
#include <math.h>
@@ -2331,6 +2332,48 @@ TEBCresume(
cleanup = 1;
goto processExceptionReturn;
+ case INST_YIELD: {
+ CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+
+ TRACE(("%.30s => ", O2S(OBJ_AT_TOS)));
+ if (!corPtr) {
+ TRACE_APPEND(("ERROR: yield outside coroutine\n"));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "yield can only be called in a coroutine", -1));
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
+ NULL);
+ goto gotError;
+ }
+
+#ifdef TCL_COMPILE_DEBUG
+ TRACE_WITH_OBJ(("yield, result="), iPtr->objResultPtr);
+ if (traceInstructions) {
+ fprintf(stdout, "\n");
+ }
+#endif
+ /* TIP #280: Record the last piece of info needed by
+ * 'TclGetSrcInfoForPc', and push the frame.
+ */
+
+ bcFramePtr->data.tebc.pc = (char *) pc;
+ iPtr->cmdFramePtr = bcFramePtr;
+
+ if (iPtr->flags & INTERP_DEBUG_FRAME) {
+ TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
+ codePtr, bcFramePtr, pc - codePtr->codeStart);
+ }
+
+ pc++;
+ cleanup = 1;
+ TEBC_YIELD();
+
+ Tcl_SetObjResult(interp, OBJ_AT_TOS);
+ TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
+ INT2PTR(0), NULL, NULL);
+
+ return TCL_OK;
+ }
+
case INST_DONE:
if (tosPtr > initTosPtr) {
/*
@@ -4045,6 +4088,103 @@ TEBCresume(
/*
* -----------------------------------------------------------------
+ * Start of general introspector instructions.
+ */
+
+ case INST_NS_CURRENT: {
+ Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
+
+ if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) {
+ TclNewLiteralStringObj(objResultPtr, "::");
+ } else {
+ TclNewStringObj(objResultPtr, currNsPtr->fullName,
+ strlen(currNsPtr->fullName));
+ }
+ TRACE_WITH_OBJ(("=> "), objResultPtr);
+ NEXT_INST_F(1, 0, 1);
+ }
+ case INST_COROUTINE_NAME: {
+ CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+
+ TclNewObj(objResultPtr);
+ if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) {
+ Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr,
+ objResultPtr);
+ }
+ TRACE_WITH_OBJ(("=> "), objResultPtr);
+ NEXT_INST_F(1, 0, 1);
+ }
+ case INST_INFO_LEVEL_NUM:
+ TclNewIntObj(objResultPtr, iPtr->varFramePtr->level);
+ TRACE_WITH_OBJ(("=> "), objResultPtr);
+ NEXT_INST_F(1, 0, 1);
+ case INST_INFO_LEVEL_ARGS: {
+ int level;
+ register CallFrame *framePtr = iPtr->varFramePtr;
+ register CallFrame *rootFramePtr = iPtr->rootFramePtr;
+
+ valuePtr = OBJ_AT_TOS;
+ if (TclGetIntFromObj(interp, valuePtr, &level) != TCL_OK) {
+ TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
+ Tcl_GetObjResult(interp));
+ goto gotError;
+ }
+ TRACE(("%d => ", level));
+ if (level <= 0) {
+ level += framePtr->level;
+ }
+ for (; (framePtr->level!=level) && (framePtr!=rootFramePtr) ;
+ framePtr = framePtr->callerVarPtr) {
+ /* Empty loop body */
+ }
+ if (framePtr == rootFramePtr) {
+ Tcl_AppendResult(interp, "bad level \"", TclGetString(valuePtr),
+ "\"", NULL);
+ TRACE_APPEND(("ERROR: bad level\n"));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL",
+ TclGetString(valuePtr), NULL);
+ goto gotError;
+ }
+ objResultPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
+ 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;
+
+ if (framePtr == NULL ||
+ !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ TRACE(("=> ERROR: no TclOO call context\n"));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "self may only be called from inside a method",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+ goto gotError;
+ }
+ contextPtr = framePtr->clientData;
+
+ /*
+ * Call out to get the name; it's expensive to compute but cached.
+ */
+
+ objResultPtr = TclOOObjectName(interp, contextPtr->oPtr);
+ TRACE_WITH_OBJ(("=> "), objResultPtr);
+ NEXT_INST_F(1, 0, 1);
+ }
+
+ /*
+ * -----------------------------------------------------------------
* Start of INST_LIST and related instructions.
*/
diff --git a/generic/tclInt.h b/generic/tclInt.h
index ea712b8..7182c05 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2797,6 +2797,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;
MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback;
+MODULE_SCOPE Tcl_NRPostProc TclNRCoroutineActivateCallback;
MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
@@ -3549,9 +3550,18 @@ 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);
MODULE_SCOPE int TclCompileInfoExistsCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileInfoLevelCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileIncrCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -3582,12 +3592,24 @@ 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);
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);
+MODULE_SCOPE int TclCompileObjectSelfCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileRegexpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -3636,6 +3658,9 @@ MODULE_SCOPE int TclCompileVariableCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileWhileCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileYieldCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclInvertOpCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 3c93400..60c40d0 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -104,7 +104,7 @@ static int NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp,
static int NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int NRNamespaceEvalCmd(ClientData dummy,
- Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
+ Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp,
@@ -160,25 +160,25 @@ static const Tcl_ObjType nsNameType = {
*/
static const EnsembleImplMap defaultNamespaceMap[] = {
- {"children", NamespaceChildrenCmd, NULL, NULL, NULL, 0},
- {"code", NamespaceCodeCmd, NULL, NULL, NULL, 0},
- {"current", NamespaceCurrentCmd, NULL, NULL, NULL, 0},
- {"delete", NamespaceDeleteCmd, NULL, NULL, NULL, 0},
- {"ensemble", TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0},
- {"eval", NamespaceEvalCmd, NULL, NRNamespaceEvalCmd, NULL, 0},
- {"exists", NamespaceExistsCmd, NULL, NULL, NULL, 0},
- {"export", NamespaceExportCmd, NULL, NULL, NULL, 0},
- {"forget", NamespaceForgetCmd, NULL, NULL, NULL, 0},
- {"import", NamespaceImportCmd, NULL, NULL, NULL, 0},
- {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0},
- {"origin", NamespaceOriginCmd, NULL, NULL, NULL, 0},
- {"parent", NamespaceParentCmd, NULL, NULL, NULL, 0},
- {"path", NamespacePathCmd, NULL, NULL, NULL, 0},
- {"qualifiers", NamespaceQualifiersCmd, NULL, NULL, NULL, 0},
- {"tail", NamespaceTailCmd, NULL, NULL, NULL, 0},
- {"unknown", NamespaceUnknownCmd, NULL, NULL, NULL, 0},
- {"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0},
- {"which", NamespaceWhichCmd, NULL, NULL, NULL, 0},
+ {"children", NamespaceChildrenCmd, 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},
+ {"eval", NamespaceEvalCmd, NULL, NRNamespaceEvalCmd, NULL, 0},
+ {"exists", NamespaceExistsCmd, NULL, NULL, NULL, 0},
+ {"export", NamespaceExportCmd, NULL, NULL, NULL, 0},
+ {"forget", NamespaceForgetCmd, NULL, NULL, NULL, 0},
+ {"import", NamespaceImportCmd, NULL, NULL, NULL, 0},
+ {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0},
+ {"origin", NamespaceOriginCmd, NULL, NULL, NULL, 0},
+ {"parent", NamespaceParentCmd, NULL, NULL, NULL, 0},
+ {"path", NamespacePathCmd, NULL, NULL, NULL, 0},
+ {"qualifiers", NamespaceQualifiersCmd, NULL, NULL, NULL, 0},
+ {"tail", NamespaceTailCmd, NULL, NULL, NULL, 0},
+ {"unknown", NamespaceUnknownCmd, NULL, NULL, NULL, 0},
+ {"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0},
+ {"which", NamespaceWhichCmd, TclCompileNamespaceWhichCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
@@ -423,7 +423,7 @@ Tcl_PopCallFrame(
framePtr->nsPtr = NULL;
if (framePtr->tailcallPtr) {
- TclSpliceTailcall(interp, framePtr->tailcallPtr);
+ TclSpliceTailcall(interp, framePtr->tailcallPtr);
}
}
@@ -689,8 +689,8 @@ Tcl_CreateNamespace(
} else if (*name == '\0') {
Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace"
" \"\": only global namespace can have empty name", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
- "CREATEGLOBAL", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
+ "CREATEGLOBAL", NULL);
return NULL;
} else {
/*
@@ -726,8 +726,8 @@ Tcl_CreateNamespace(
) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create namespace \"%s\": already exists", name));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
- "CREATEEXISTING", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
+ "CREATEEXISTING", NULL);
return NULL;
}
}
@@ -1337,7 +1337,7 @@ Tcl_Export(
if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid export pattern"
" \"%s\": pattern can't specify a namespace", pattern));
- Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL);
return TCL_ERROR;
}
@@ -1542,7 +1542,7 @@ Tcl_Import(
if (strlen(pattern) == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1));
- Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL);
return TCL_ERROR;
}
TclGetNamespaceForQualName(interp, pattern, nsPtr,
@@ -1560,12 +1560,12 @@ Tcl_Import(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no namespace specified in import pattern \"%s\"",
pattern));
- Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL);
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"import pattern \"%s\" tries to import from namespace"
" \"%s\" into itself", pattern, importNsPtr->name));
- Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL);
}
return TCL_ERROR;
}
@@ -1688,7 +1688,7 @@ DoImport(
" containing command \"%s\"",
pattern, Tcl_DStringValue(&ds)));
Tcl_DStringFree(&ds);
- Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL);
return TCL_ERROR;
}
}
@@ -1728,7 +1728,7 @@ DoImport(
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't import command \"%s\": already exists", cmdName));
- Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -3285,12 +3285,12 @@ NRNamespaceEvalCmd(
}
if (iPtr->ensembleRewrite.sourceObjs == NULL) {
- framePtr->objc = objc;
- framePtr->objv = objv;
+ framePtr->objc = objc;
+ framePtr->objv = objv;
} else {
- framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
- - iPtr->ensembleRewrite.numInsertedObjs;
- framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
+ framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
+ - iPtr->ensembleRewrite.numInsertedObjs;
+ framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
}
if (objc == 3) {
@@ -3748,12 +3748,12 @@ NRNamespaceInscopeCmd(
}
if (iPtr->ensembleRewrite.sourceObjs == NULL) {
- framePtr->objc = objc;
- framePtr->objv = objv;
+ framePtr->objc = objc;
+ framePtr->objv = objv;
} else {
- framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
- - iPtr->ensembleRewrite.numInsertedObjs;
- framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
+ framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
+ - iPtr->ensembleRewrite.numInsertedObjs;
+ framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
}
/*
@@ -3958,15 +3958,15 @@ NamespacePathCmd(
*/
if (objc == 1) {
- Tcl_Obj *resultObj = Tcl_NewObj();
+ Tcl_Obj *resultObj = Tcl_NewObj();
for (i=0 ; i<nsPtr->commandPathLength ; i++) {
if (nsPtr->commandPathArray[i].nsPtr != NULL) {
- Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(
- nsPtr->commandPathArray[i].nsPtr->fullName, -1));
+ Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(
+ nsPtr->commandPathArray[i].nsPtr->fullName, -1));
}
}
- Tcl_SetObjResult(interp, resultObj);
+ Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
@@ -4843,8 +4843,8 @@ TclLogCommandInfo(
int length, /* Number of bytes in command (-1 means use
* all bytes up to first null byte). */
const unsigned char *pc, /* Current pc of bytecode execution context */
- Tcl_Obj **tosPtr) /* Current stack of bytecode execution
- * context */
+ Tcl_Obj **tosPtr) /* Current stack of bytecode execution
+ * context */
{
register const char *p;
Interp *iPtr = (Interp *) interp;
@@ -4861,55 +4861,55 @@ TclLogCommandInfo(
}
if (command != NULL) {
- /*
- * Compute the line number where the error occurred.
- */
-
- iPtr->errorLine = 1;
- for (p = script; p != command; p++) {
- if (*p == '\n') {
- iPtr->errorLine++;
- }
- }
-
- if (length < 0) {
- length = strlen(command);
- }
- overflow = (length > limit);
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ /*
+ * Compute the line number where the error occurred.
+ */
+
+ iPtr->errorLine = 1;
+ for (p = script; p != command; p++) {
+ if (*p == '\n') {
+ iPtr->errorLine++;
+ }
+ }
+
+ if (length < 0) {
+ length = strlen(command);
+ }
+ overflow = (length > limit);
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL)
? "while executing" : "invoked from within"),
(overflow ? limit : length), command,
(overflow ? "..." : "")));
- varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY,
+ varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY,
NULL, 0, 0, &arrayPtr);
- if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) {
- /*
- * Should not happen.
- */
-
- return;
- } else {
- Tcl_HashEntry *hPtr
+ if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) {
+ /*
+ * Should not happen.
+ */
+
+ return;
+ } else {
+ Tcl_HashEntry *hPtr
= Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
- VarTrace *tracePtr = Tcl_GetHashValue(hPtr);
+ VarTrace *tracePtr = Tcl_GetHashValue(hPtr);
- if (tracePtr->traceProc != EstablishErrorInfoTraces) {
- /*
- * The most recent trace set on ::errorInfo is not the one the
- * core itself puts on last. This means some other code is
+ if (tracePtr->traceProc != EstablishErrorInfoTraces) {
+ /*
+ * The most recent trace set on ::errorInfo is not the one the
+ * core itself puts on last. This means some other code is
* tracing the variable, and the additional trace(s) might be
* write traces that expect the timing of writes to
* ::errorInfo that existed Tcl releases before 8.5. To
* satisfy that compatibility need, we write the current
* -errorinfo value to the ::errorInfo variable.
- */
+ */
- Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo,
+ Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo,
TCL_GLOBAL_ONLY);
- }
- }
+ }
+ }
}
/*
@@ -4917,60 +4917,60 @@ TclLogCommandInfo(
*/
if (Tcl_IsShared(iPtr->errorStack)) {
- Tcl_Obj *newObj;
-
- newObj = Tcl_DuplicateObj(iPtr->errorStack);
- Tcl_DecrRefCount(iPtr->errorStack);
- Tcl_IncrRefCount(newObj);
- iPtr->errorStack = newObj;
+ Tcl_Obj *newObj;
+
+ newObj = Tcl_DuplicateObj(iPtr->errorStack);
+ Tcl_DecrRefCount(iPtr->errorStack);
+ Tcl_IncrRefCount(newObj);
+ iPtr->errorStack = newObj;
}
if (iPtr->resetErrorStack) {
int len;
- iPtr->resetErrorStack = 0;
+ iPtr->resetErrorStack = 0;
Tcl_ListObjLength(interp, iPtr->errorStack, &len);
- /*
- * Reset while keeping the list intrep as much as possible.
- */
-
- Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
- if (pc != NULL) {
- Tcl_Obj *innerContext;
-
- innerContext = TclGetInnerContext(interp, pc, tosPtr);
- if (innerContext != NULL) {
- Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
- iPtr->innerLiteral);
- Tcl_ListObjAppendElement(NULL, iPtr->errorStack, innerContext);
- }
- } else if (command != NULL) {
- Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
- iPtr->innerLiteral);
- Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
- Tcl_NewStringObj(command, length));
- }
+ /*
+ * Reset while keeping the list intrep as much as possible.
+ */
+
+ Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
+ if (pc != NULL) {
+ Tcl_Obj *innerContext;
+
+ innerContext = TclGetInnerContext(interp, pc, tosPtr);
+ if (innerContext != NULL) {
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
+ iPtr->innerLiteral);
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack, innerContext);
+ }
+ } else if (command != NULL) {
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
+ iPtr->innerLiteral);
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
+ Tcl_NewStringObj(command, length));
+ }
}
if (!iPtr->framePtr->objc) {
- /*
- * Special frame, nothing to report.
- */
+ /*
+ * Special frame, nothing to report.
+ */
} else if (iPtr->varFramePtr != iPtr->framePtr) {
- /*
- * uplevel case, [lappend errorstack UP $relativelevel]
- */
+ /*
+ * uplevel case, [lappend errorstack UP $relativelevel]
+ */
- Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral);
- Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj(
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral);
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj(
iPtr->framePtr->level - iPtr->varFramePtr->level));
} else if (iPtr->framePtr != iPtr->rootFramePtr) {
- /*
- * normal case, [lappend errorstack CALL [info level 0]]
- */
+ /*
+ * normal case, [lappend errorstack CALL [info level 0]]
+ */
- Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral);
- Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj(
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral);
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj(
iPtr->framePtr->objc, iPtr->framePtr->objv));
}
}
@@ -4980,8 +4980,8 @@ TclLogCommandInfo(
*
* TclErrorStackResetIf --
*
- * The TIP 348 reset/no-bc part of TLCI, for specific use by
- * TclCompileSyntaxError.
+ * The TIP 348 reset/no-bc part of TLCI, for specific use by
+ * TclCompileSyntaxError.
*
* Results:
* None.
@@ -5002,27 +5002,27 @@ TclErrorStackResetIf(
Interp *iPtr = (Interp *) interp;
if (Tcl_IsShared(iPtr->errorStack)) {
- Tcl_Obj *newObj;
-
- newObj = Tcl_DuplicateObj(iPtr->errorStack);
- Tcl_DecrRefCount(iPtr->errorStack);
- Tcl_IncrRefCount(newObj);
- iPtr->errorStack = newObj;
+ Tcl_Obj *newObj;
+
+ newObj = Tcl_DuplicateObj(iPtr->errorStack);
+ Tcl_DecrRefCount(iPtr->errorStack);
+ Tcl_IncrRefCount(newObj);
+ iPtr->errorStack = newObj;
}
if (iPtr->resetErrorStack) {
int len;
- iPtr->resetErrorStack = 0;
+ iPtr->resetErrorStack = 0;
Tcl_ListObjLength(interp, iPtr->errorStack, &len);
- /*
- * Reset while keeping the list intrep as much as possible.
- */
+ /*
+ * Reset while keeping the list intrep as much as possible.
+ */
- Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
- Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral);
- Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
- Tcl_NewStringObj(msg, length));
+ Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral);
+ Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
+ Tcl_NewStringObj(msg, length));
}
}
@@ -5065,6 +5065,5 @@ Tcl_LogCommandInfo(
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
- * indent-tabs-mode: nil
* End:
*/
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 04a2bf7..d6d2d6a 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -314,6 +314,7 @@ InitFoundation(
Foundation *fPtr = ckalloc(sizeof(Foundation));
Tcl_Obj *namePtr, *argsPtr, *bodyPtr;
Tcl_DString buffer;
+ Command *cmdPtr;
int i;
/*
@@ -440,8 +441,9 @@ InitFoundation(
NULL);
Tcl_CreateObjCommand(interp, "::oo::Helpers::nextto", TclOONextToObjCmd,
NULL, NULL);
- Tcl_CreateObjCommand(interp, "::oo::Helpers::self", TclOOSelfObjCmd, NULL,
- NULL);
+ cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self",
+ TclOOSelfObjCmd, NULL, NULL);
+ cmdPtr->compileProc = TclCompileObjectSelfCmd;
Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL,
NULL);
Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL,
diff --git a/tests/info.test b/tests/info.test
index 7dd63b7..5078e11 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -1955,6 +1955,12 @@ test info-38.2 {location information for uplevel, dl, direct-literal} -match glo
* {type source line 1951 file info.test cmd etrace level 1}
* {type source line 1949 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub}
+# This test at the end of this file _only_ to avoid disturbing above line
+# numbers. It _belongs_ after info-9.12
+test info-9.13 {info level option, value in global context} -body {
+ uplevel #0 {info level 2}
+} -returnCodes error -result {bad level "2"}
+
# -------------------------------------------------------------------------
unset -nocomplain res
generated by cgit v0.12 at 2025-12-13 09:38:31 (GMT)