summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog24
-rw-r--r--generic/tclAssembly.c28
-rw-r--r--generic/tclBasic.c30
-rw-r--r--generic/tclCmdIL.c6
-rw-r--r--generic/tclCmdMZ.c8
-rw-r--r--generic/tclCompCmds.c1384
-rw-r--r--generic/tclCompCmdsSZ.c525
-rw-r--r--generic/tclCompile.c129
-rw-r--r--generic/tclCompile.h34
-rw-r--r--generic/tclDictObj.c6
-rw-r--r--generic/tclExecute.c537
-rw-r--r--generic/tclInt.h84
-rw-r--r--generic/tclNamesp.c275
-rw-r--r--generic/tclOO.c6
-rw-r--r--generic/tclOOInfo.c85
-rw-r--r--generic/tclVar.c6
-rw-r--r--tests/dict.test48
-rw-r--r--tests/info.test6
18 files changed, 2801 insertions, 420 deletions
diff --git a/ChangeLog b/ChangeLog
index e6a6f97..d9fa2a0 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,22 @@
+2012-11-05 Donal K. Fellows <dkf@users.sf.net>
+
+ Added bytecode compilation of many Tcl commands. Some of these are
+ total compilations and some are only partial (i.e., only compile in
+ some cases). The (sub-)commands affected are:
+ * array: exists, set, unset
+ * dict: create, exists, merge
+ * format: (simple cases only)
+ * info: commands, coroutine, level, object
+ * info object: class, isa object, namespace
+ * namespace: current, code, qualifiers, tail, which
+ * regsub: (only cases convertable to simple [string map])
+ * self: (only no-argument and [self object] cases)
+ * string: first, last, map, range
+ * tailcall:
+ * yield:
+
+ [This was work originally done on the 'dkf-compile-misc-info' branch.]
+
2012-11-05 Jan Nijtmans <nijtmans@users.sf.net>
IMPLEMENTATION OF TIP#413
@@ -12,6 +31,11 @@
* generic/regc_locale.c: Regexp engine must match [string is space]
* doc/string.n
* tests/string.test
+ ***POTENTIAL INCOMPATIBILITY***
+ Code that relied on characters not previously trimmed being not
+ removed will notice a difference; it is believed that this is rare,
+ but a workaround to get the behavior in Tcl 8.5 is to use " \t\n\r" as
+ an explicit trim set.
2012-10-31 Jan Nijtmans <nijtmans@users.sf.net>
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 83f4fe9..7833105 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -362,6 +362,10 @@ static const TalInstDesc TalInstructionTable[] = {
| INST_APPEND_ARRAY4), 2, 1},
{"appendArrayStk", ASSEM_1BYTE, INST_APPEND_ARRAY_STK, 3, 1},
{"appendStk", ASSEM_1BYTE, INST_APPEND_STK, 2, 1},
+ {"arrayExistsImm", ASSEM_LVT4, INST_ARRAY_EXISTS_IMM, 0, 1},
+ {"arrayExistsStk", ASSEM_1BYTE, INST_ARRAY_EXISTS_STK, 1, 1},
+ {"arrayMakeImm", ASSEM_LVT4, INST_ARRAY_MAKE_IMM, 0, 0},
+ {"arrayMakeStk", ASSEM_1BYTE, INST_ARRAY_MAKE_STK, 1, 0},
{"beginCatch", ASSEM_BEGIN_CATCH,
INST_BEGIN_CATCH4, 0, 0},
{"bitand", ASSEM_1BYTE, INST_BITAND, 2, 1},
@@ -369,7 +373,10 @@ 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},
+ {"dictExists", ASSEM_DICT_GET, INST_DICT_EXISTS, INT_MIN,1},
{"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 1},
{"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1},
{"dictIncrImm", ASSEM_SINT4_LVT4,
@@ -406,6 +413,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 +466,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
@@ -467,11 +477,19 @@ static const TalInstDesc TalInstructionTable[] = {
{"storeStk", ASSEM_1BYTE, INST_STORE_SCALAR_STK, 2, 1},
{"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1},
{"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1},
+ {"strfind", ASSEM_1BYTE, INST_STR_FIND, 2, 1},
{"strindex", ASSEM_1BYTE, INST_STR_INDEX, 2, 1},
{"strlen", ASSEM_1BYTE, INST_STR_LEN, 1, 1},
+ {"strmap", ASSEM_1BYTE, INST_STR_MAP, 3, 1},
{"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1},
{"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1},
+ {"strrange", ASSEM_1BYTE, INST_STR_RANGE, 3, 1},
+ {"strrfind", ASSEM_1BYTE, INST_STR_FIND_LAST, 2, 1},
{"sub", ASSEM_1BYTE, INST_SUB, 2, 1},
+ {"tclooClass", ASSEM_1BYTE, INST_TCLOO_CLASS, 1, 1},
+ {"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1},
+ {"tclooNamespace", ASSEM_1BYTE, INST_TCLOO_NS, 1, 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 +499,8 @@ 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},
+ {"verifyDict", ASSEM_1BYTE, INST_DICT_VERIFY, 1, 0},
+ {"yield", ASSEM_1BYTE, INST_YIELD, 1, 1},
{NULL, 0, 0, 0, 0}
};
@@ -499,7 +519,13 @@ static const unsigned char NonThrowingByteCodes[] = {
INST_OVER, /* 95 */
INST_PUSH_RETURN_OPTIONS, /* 108 */
INST_REVERSE, /* 126 */
- INST_NOP /* 132 */
+ INST_NOP, /* 132 */
+ INST_STR_MAP, /* 143 */
+ INST_STR_FIND, /* 144 */
+ INST_COROUTINE_NAME, /* 149 */
+ INST_NS_CURRENT, /* 151 */
+ INST_INFO_LEVEL_NUM, /* 152 */
+ INST_RESOLVE_COMMAND /* 154 */
};
/*
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 3848d5b..bce6479 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -131,13 +131,11 @@ 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);
static Tcl_NRPostProc NRRunObjProc;
-static Tcl_NRPostProc NRTailcallEval;
static Tcl_ObjCmdProc OldMathFuncProc;
static void OldMathFuncDeleteProc(ClientData clientData);
static void ProcessUnexpectedResult(Tcl_Interp *interp,
@@ -219,7 +217,7 @@ static const CmdInfo builtInCmds[] = {
{"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, 1},
{"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, 1},
{"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, 1},
- {"format", Tcl_FormatObjCmd, NULL, NULL, 1},
+ {"format", Tcl_FormatObjCmd, TclCompileFormatCmd, NULL, 1},
{"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, 1},
{"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, 1},
{"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, 1},
@@ -241,7 +239,7 @@ static const CmdInfo builtInCmds[] = {
{"package", Tcl_PackageObjCmd, NULL, NULL, 1},
{"proc", Tcl_ProcObjCmd, NULL, NULL, 1},
{"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, 1},
- {"regsub", Tcl_RegsubObjCmd, NULL, NULL, 1},
+ {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, 1},
{"rename", Tcl_RenameObjCmd, NULL, NULL, 1},
{"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, 1},
{"scan", Tcl_ScanObjCmd, NULL, NULL, 1},
@@ -249,7 +247,7 @@ static const CmdInfo builtInCmds[] = {
{"split", Tcl_SplitObjCmd, NULL, NULL, 1},
{"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, 1},
{"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, 1},
- {"tailcall", NULL, NULL, TclNRTailcallObjCmd, 1},
+ {"tailcall", NULL, TclCompileTailcallCmd, TclNRTailcallObjCmd, 1},
{"throw", Tcl_ThrowObjCmd, TclCompileThrowCmd, NULL, 1},
{"trace", Tcl_TraceObjCmd, NULL, NULL, 1},
{"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, 1},
@@ -258,7 +256,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},
/*
@@ -8323,7 +8321,7 @@ TclNRTailcallObjCmd(
return TCL_ERROR;
}
- if (!iPtr->varFramePtr->isProcCallFrame) { /* or is upleveled */
+ if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { /* or is upleveled */
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"tailcall can only be called from a proc or lambda", -1));
Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
@@ -8363,7 +8361,7 @@ TclNRTailcallObjCmd(
}
Tcl_IncrRefCount(nsObjPtr);
- TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr,
+ TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr,
NULL, NULL);
tailcallPtr = TOP_CB(interp);
TOP_CB(interp) = tailcallPtr->nextPtr;
@@ -8373,7 +8371,7 @@ TclNRTailcallObjCmd(
}
int
-NRTailcallEval(
+TclNRTailcallEval(
ClientData data[],
Tcl_Interp *interp,
int result)
@@ -8495,7 +8493,7 @@ TclNRYieldObjCmd(
}
NRE_ASSERT(!COR_IS_SUSPENDED(corPtr));
- TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr,
+ TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
clientData, NULL, NULL);
return TCL_OK;
}
@@ -8567,7 +8565,7 @@ YieldToCallback(
* yieldTo: invoke the command using tailcall tech.
*/
- TclNRAddCallback(interp, NRTailcallEval, listPtr, nsPtr, NULL, NULL);
+ TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsPtr, NULL, NULL);
cbPtr = TOP_CB(interp);
TOP_CB(interp) = cbPtr->nextPtr;
@@ -8712,7 +8710,7 @@ NRCoroutineExitCallback(
/*
*----------------------------------------------------------------------
*
- * NRCoroutineActivateCallback --
+ * TclNRCoroutineActivateCallback --
*
* This is the workhorse for coroutines: it implements both yield and
* resume.
@@ -8726,8 +8724,8 @@ NRCoroutineExitCallback(
*----------------------------------------------------------------------
*/
-static int
-NRCoroutineActivateCallback(
+int
+TclNRCoroutineActivateCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
@@ -8902,7 +8900,7 @@ TclNRInterpCoroutine(
break;
}
- TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr,
+ TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
NULL, NULL, NULL);
return TCL_OK;
}
@@ -9059,7 +9057,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/tclCmdMZ.c b/generic/tclCmdMZ.c
index 88b3420..fc957c4 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -3327,14 +3327,14 @@ TclInitStringCmd(
{"bytelength", StringBytesCmd, NULL, NULL, NULL, 0},
{"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0},
{"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0},
- {"first", StringFirstCmd, NULL, NULL, NULL, 0},
+ {"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0},
{"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0},
{"is", StringIsCmd, NULL, NULL, NULL, 0},
- {"last", StringLastCmd, NULL, NULL, NULL, 0},
+ {"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0},
{"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0},
- {"map", StringMapCmd, NULL, NULL, NULL, 0},
+ {"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0},
{"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL, 0},
- {"range", StringRangeCmd, NULL, NULL, NULL, 0},
+ {"range", StringRangeCmd, TclCompileStringRangeCmd, NULL, NULL, 0},
{"repeat", StringReptCmd, NULL, NULL, NULL, 0},
{"replace", StringRplcCmd, NULL, NULL, NULL, 0},
{"reverse", StringRevCmd, NULL, NULL, NULL, 0},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index fc60016..160fa3c 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -15,6 +15,7 @@
#include "tclInt.h"
#include "tclCompile.h"
+#include <assert.h>
/*
* Prototypes for procedures defined later in this file:
@@ -225,6 +226,245 @@ TclCompileAppendCmd(
/*
*----------------------------------------------------------------------
*
+ * TclCompileArray*Cmd --
+ *
+ * Functions called to compile "array" sucommands.
+ *
+ * Results:
+ * All return TCL_OK for a successful compile, and TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "array" subcommand at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileArrayExistsCmd(
+ Tcl_Interp *interp, /* Used for looking up stuff. */
+ 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;
+ int simpleVarName, isScalar, localIndex;
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ PushVarNameWord(interp, tokenPtr, envPtr, 0,
+ &localIndex, &simpleVarName, &isScalar, 1);
+ if (!isScalar) {
+ return TCL_ERROR;
+ }
+
+ if (localIndex >= 0) {
+ TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
+ } else {
+ TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr);
+ }
+ return TCL_OK;
+}
+
+int
+TclCompileArraySetCmd(
+ Tcl_Interp *interp, /* Used for looking up stuff. */
+ 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;
+ int simpleVarName, isScalar, localIndex;
+ int dataVar, iterVar, keyVar, valVar, infoIndex;
+ int back, fwd, offsetBack, offsetFwd, savedStackDepth;
+ ForeachInfo *infoPtr;
+
+ if (parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ PushVarNameWord(interp, tokenPtr, envPtr, 0,
+ &localIndex, &simpleVarName, &isScalar, 1);
+ if (!isScalar) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+
+ /*
+ * Special case: literal empty value argument is just an "ensure array"
+ * operation.
+ */
+
+ if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD && tokenPtr[1].size == 0) {
+ if (localIndex >= 0) {
+ TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
+ TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr);
+ TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr);
+ } else {
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr);
+ TclEmitInstInt1(INST_JUMP_TRUE1, 5, envPtr);
+ savedStackDepth = envPtr->currStackDepth;
+ TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr);
+ TclEmitInstInt1(INST_JUMP1, 3, envPtr);
+ envPtr->currStackDepth = savedStackDepth;
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+ PushLiteral(envPtr, "", 0);
+ return TCL_OK;
+ }
+
+ /*
+ * Prepare for the internal foreach.
+ */
+
+ if (envPtr->procPtr == NULL) {
+ return TCL_ERROR;
+ }
+ dataVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ iterVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ keyVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ valVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+
+ infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *));
+ infoPtr->numLists = 1;
+ infoPtr->firstValueTemp = dataVar;
+ infoPtr->loopCtTemp = iterVar;
+ infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) * 2*sizeof(int));
+ infoPtr->varLists[0]->numVars = 2;
+ infoPtr->varLists[0]->varIndexes[0] = keyVar;
+ infoPtr->varLists[0]->varIndexes[1] = valVar;
+ infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr);
+
+ /*
+ * Start issuing instructions to write to the array.
+ */
+
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_LIST_LENGTH, envPtr);
+ PushLiteral(envPtr, "1", 1);
+ TclEmitOpcode( INST_BITAND, envPtr);
+ offsetFwd = CurrentOffset(envPtr);
+ TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr);
+ savedStackDepth = envPtr->currStackDepth;
+ PushLiteral(envPtr, "list must have an even number of elements",
+ strlen("list must have an even number of elements"));
+ PushLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}",
+ strlen("-errorCode {TCL ARGUMENT FORMAT}"));
+ TclEmitInstInt4( INST_RETURN_IMM, 1, envPtr);
+ TclEmitInt4( 0, envPtr);
+ envPtr->currStackDepth = savedStackDepth;
+ fwd = CurrentOffset(envPtr) - offsetFwd;
+ TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
+ Emit14Inst( INST_STORE_SCALAR, dataVar, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+
+ if (localIndex >= 0) {
+ TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
+ TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr);
+ TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr);
+ TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);
+ offsetBack = CurrentOffset(envPtr);
+ TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
+ offsetFwd = CurrentOffset(envPtr);
+ TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
+ savedStackDepth = envPtr->currStackDepth;
+ Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr);
+ Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr);
+ Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ back = offsetBack - CurrentOffset(envPtr);
+ TclEmitInstInt1(INST_JUMP1, back, envPtr);
+ fwd = CurrentOffset(envPtr) - offsetFwd;
+ TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
+ envPtr->currStackDepth = savedStackDepth;
+ } else {
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr);
+ TclEmitInstInt1(INST_JUMP_TRUE1, 4, envPtr);
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr);
+ TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);
+ offsetBack = CurrentOffset(envPtr);
+ TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
+ offsetFwd = CurrentOffset(envPtr);
+ TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
+ savedStackDepth = envPtr->currStackDepth;
+ TclEmitOpcode( INST_DUP, envPtr);
+ Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr);
+ Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr);
+ TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ back = offsetBack - CurrentOffset(envPtr);
+ TclEmitInstInt1(INST_JUMP1, back, envPtr);
+ fwd = CurrentOffset(envPtr) - offsetFwd;
+ TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
+ envPtr->currStackDepth = savedStackDepth;
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+ TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( dataVar, envPtr);
+ PushLiteral(envPtr, "", 0);
+ return TCL_OK;
+}
+
+int
+TclCompileArrayUnsetCmd(
+ Tcl_Interp *interp, /* Used for looking up stuff. */
+ 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 = TokenAfter(parsePtr->tokenPtr);
+ int simpleVarName, isScalar, localIndex, savedStackDepth;
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+
+ PushVarNameWord(interp, tokenPtr, envPtr, 0,
+ &localIndex, &simpleVarName, &isScalar, 1);
+ if (!isScalar) {
+ return TCL_ERROR;
+ }
+
+ if (localIndex >= 0) {
+ TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
+ TclEmitInstInt1(INST_JUMP_FALSE1, 8, envPtr);
+ TclEmitInstInt1(INST_UNSET_SCALAR, 1, envPtr);
+ TclEmitInt4( localIndex, envPtr);
+ } else {
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr);
+ TclEmitInstInt1(INST_JUMP_FALSE1, 6, envPtr);
+ savedStackDepth = envPtr->currStackDepth;
+ TclEmitInstInt1(INST_UNSET_STK, 1, envPtr);
+ TclEmitInstInt1(INST_JUMP1, 3, envPtr);
+ envPtr->currStackDepth = savedStackDepth;
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+ PushLiteral(envPtr, "", 0);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompileBreakCmd --
*
* Procedure called to compile the "break" command.
@@ -258,6 +498,7 @@ TclCompileBreakCmd(
*/
TclEmitOpcode(INST_BREAK, envPtr);
+ PushLiteral(envPtr, "", 0); /* Evil hack! */
return TCL_OK;
}
@@ -564,6 +805,7 @@ TclCompileContinueCmd(
*/
TclEmitOpcode(INST_CONTINUE, envPtr);
+ PushLiteral(envPtr, "", 0); /* Evil hack! */
return TCL_OK;
}
@@ -582,26 +824,6 @@ TclCompileContinueCmd(
* Instructions are added to envPtr to execute the "dict" subcommand at
* runtime.
*
- * Notes:
- * The following commands are in fairly common use and are possibly worth
- * bytecoding:
- * dict append
- * dict create [*]
- * dict exists [*]
- * dict for
- * dict get [*]
- * dict incr
- * dict keys [*]
- * dict lappend
- * dict map
- * dict set
- * dict unset
- *
- * In practice, those that are pure-value operators (marked with [*]) can
- * probably be left alone (except perhaps [dict get] which is very very
- * common) and [dict update] should be considered instead (really big
- * win!)
- *
*----------------------------------------------------------------------
*/
@@ -666,6 +888,7 @@ TclCompileDictSetCmd(
TclEmitInstInt4( INST_DICT_SET, numWords-2, envPtr);
TclEmitInt4( dictVarIndex, envPtr);
+ TclAdjustStackDepth(-1, envPtr);
return TCL_OK;
}
@@ -783,6 +1006,44 @@ TclCompileDictGetCmd(
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4(INST_DICT_GET, numWords-1, envPtr);
+ TclAdjustStackDepth(-1, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileDictExistsCmd(
+ Tcl_Interp *interp, /* Used for looking up stuff. */
+ 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;
+ int numWords, i;
+ DefineLineInformation; /* TIP #280 */
+
+ /*
+ * There must be at least two arguments after the command (the single-arg
+ * case is legal, but too special and magic for us to deal with here).
+ */
+
+ if (parsePtr->numWords < 3) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ numWords = parsePtr->numWords-1;
+
+ /*
+ * Now we do the code generation.
+ */
+
+ for (i=0 ; i<numWords ; i++) {
+ CompileWord(envPtr, tokenPtr, interp, i);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ TclEmitInstInt4(INST_DICT_EXISTS, numWords-1, envPtr);
+ TclAdjustStackDepth(-1, envPtr);
return TCL_OK;
}
@@ -843,7 +1104,212 @@ TclCompileDictUnsetCmd(
*/
TclEmitInstInt4( INST_DICT_UNSET, parsePtr->numWords-2, envPtr);
- TclEmitInt4( dictVarIndex, envPtr);
+ TclEmitInt4( dictVarIndex, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileDictCreateCmd(
+ Tcl_Interp *interp, /* Used for looking up stuff. */
+ 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 */
+ int worker; /* Temp var for building the value in. */
+ Tcl_Token *tokenPtr;
+ Tcl_Obj *keyObj, *valueObj, *dictObj;
+ const char *bytes;
+ int i, len;
+
+ if ((parsePtr->numWords & 1) == 0) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * See if we can build the value at compile time...
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ dictObj = Tcl_NewObj();
+ Tcl_IncrRefCount(dictObj);
+ for (i=1 ; i<parsePtr->numWords ; i+=2) {
+ keyObj = Tcl_NewObj();
+ Tcl_IncrRefCount(keyObj);
+ if (!TclWordKnownAtCompileTime(tokenPtr, keyObj)) {
+ Tcl_DecrRefCount(keyObj);
+ Tcl_DecrRefCount(dictObj);
+ goto nonConstant;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ valueObj = Tcl_NewObj();
+ Tcl_IncrRefCount(valueObj);
+ if (!TclWordKnownAtCompileTime(tokenPtr, valueObj)) {
+ Tcl_DecrRefCount(keyObj);
+ Tcl_DecrRefCount(valueObj);
+ Tcl_DecrRefCount(dictObj);
+ goto nonConstant;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ Tcl_DictObjPut(NULL, dictObj, keyObj, valueObj);
+ Tcl_DecrRefCount(keyObj);
+ Tcl_DecrRefCount(valueObj);
+ }
+
+ /*
+ * We did! Excellent. The "verifyDict" is to do type forcing.
+ */
+
+ bytes = Tcl_GetStringFromObj(dictObj, &len);
+ PushLiteral(envPtr, bytes, len);
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_DICT_VERIFY, envPtr);
+ Tcl_DecrRefCount(dictObj);
+ return TCL_OK;
+
+ /*
+ * Otherwise, we've got to issue runtime code to do the building, which we
+ * do by [dict set]ting into an unnamed local variable. This requires that
+ * we are in a context with an LVT.
+ */
+
+ nonConstant:
+ worker = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ if (worker < 0) {
+ return TCL_ERROR;
+ }
+
+ PushLiteral(envPtr, "", 0);
+ Emit14Inst( INST_STORE_SCALAR, worker, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ for (i=1 ; i<parsePtr->numWords ; i+=2) {
+ CompileWord(envPtr, tokenPtr, interp, i);
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, i+1);
+ tokenPtr = TokenAfter(tokenPtr);
+ TclEmitInstInt4( INST_DICT_SET, 1, envPtr);
+ TclEmitInt4( worker, envPtr);
+ TclAdjustStackDepth(-1, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+ Emit14Inst( INST_LOAD_SCALAR, worker, envPtr);
+ TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( worker, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileDictMergeCmd(
+ Tcl_Interp *interp, /* Used for looking up stuff. */
+ 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;
+ int i, workerIndex, infoIndex, outLoop;
+
+ /*
+ * Deal with some special edge cases. Note that in the case with one
+ * argument, the only thing to do is to verify the dict-ness.
+ */
+
+ if (parsePtr->numWords < 2) {
+ PushLiteral(envPtr, "", 0);
+ return TCL_OK;
+ } else if (parsePtr->numWords == 2) {
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_DICT_VERIFY, envPtr);
+ return TCL_OK;
+ }
+
+ /*
+ * There's real merging work to do.
+ *
+ * Allocate some working space. This means we'll only ever compile this
+ * command when there's an LVT present.
+ */
+
+ workerIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ if (workerIndex < 0) {
+ return TCL_ERROR;
+ }
+ infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+
+ /*
+ * Get the first dictionary and verify that it is so.
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_DICT_VERIFY, envPtr);
+ Emit14Inst( INST_STORE_SCALAR, workerIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+
+ /*
+ * For each of the remaining dictionaries...
+ */
+
+ outLoop = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+ TclEmitInstInt4( INST_BEGIN_CATCH4, outLoop, envPtr);
+ ExceptionRangeStarts(envPtr, outLoop);
+ for (i=2 ; i<parsePtr->numWords ; i++) {
+ /*
+ * Get the dictionary, and merge its pairs into the first dict (using
+ * a small loop).
+ */
+
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, i);
+ TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr);
+ TclEmitInstInt1( INST_JUMP_TRUE1, 24, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
+ TclEmitInstInt4( INST_DICT_SET, 1, envPtr);
+ TclEmitInt4( workerIndex, envPtr);
+ TclAdjustStackDepth(-1, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr);
+ TclEmitInstInt1( INST_JUMP_FALSE1, -20, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
+ }
+ ExceptionRangeEnds(envPtr, outLoop);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
+
+ /*
+ * Clean up any state left over.
+ */
+
+ Emit14Inst( INST_LOAD_SCALAR, workerIndex, envPtr);
+ TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( workerIndex, envPtr);
+ TclEmitInstInt1( INST_JUMP1, 18, envPtr);
+
+ /*
+ * If an exception happens when starting to iterate over the second (and
+ * subsequent) dicts. This is strictly not necessary, but it is nice.
+ */
+
+ ExceptionRangeTarget(envPtr, outLoop, catchOffset);
+ TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
+ TclEmitOpcode( INST_PUSH_RESULT, envPtr);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
+ TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( workerIndex, envPtr);
+ TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
+ TclEmitOpcode( INST_RETURN_STK, envPtr);
+
return TCL_OK;
}
@@ -1036,6 +1502,7 @@ CompileDictEachCmd(
TclEmitInstInt4(INST_OVER, 1, envPtr);
TclEmitInstInt4(INST_DICT_SET, 1, envPtr);
TclEmitInt4( collectVar, envPtr);
+ TclAdjustStackDepth(-1, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
TclEmitOpcode( INST_POP, envPtr);
@@ -1070,7 +1537,7 @@ CompileDictEachCmd(
ExceptionRangeTarget(envPtr, loopRange, breakOffset);
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
- TclEmitInt4( infoIndex, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
TclEmitOpcode( INST_END_CATCH, envPtr);
endTargetOffset = CurrentOffset(envPtr);
TclEmitInstInt4( INST_JUMP4, 0, envPtr);
@@ -1084,7 +1551,7 @@ CompileDictEachCmd(
TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
- TclEmitInt4( infoIndex, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
TclEmitOpcode( INST_END_CATCH, envPtr);
if (collect == TCL_EACH_COLLECT) {
TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr);
@@ -1098,7 +1565,7 @@ CompileDictEachCmd(
* easy!) Note that we skip the END_CATCH. [Bug 1382528]
*/
- envPtr->currStackDepth = savedStackDepth+2;
+ envPtr->currStackDepth = savedStackDepth + 2;
jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset;
TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement,
envPtr->codeStart + emptyTargetOffset);
@@ -1294,6 +1761,7 @@ TclCompileDictUpdateCmd(
(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
}
TclStackFree(interp, keyTokenPtrs);
+ envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
@@ -1542,6 +2010,7 @@ TclCompileDictWithCmd(
PushLiteral(envPtr, "", 0);
}
}
+ envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
@@ -1660,6 +2129,7 @@ TclCompileDictWithCmd(
* Prepare for the start of the next command.
*/
+ envPtr->currStackDepth = savedStackDepth + 1;
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
@@ -1759,6 +2229,7 @@ TclCompileErrorCmd(
* However, we only deal with the case where there is just a message.
*/
Tcl_Token *messageTokenPtr;
+ int savedStackDepth = envPtr->currStackDepth;
DefineLineInformation; /* TIP #280 */
if (parsePtr->numWords != 2) {
@@ -1769,6 +2240,7 @@ TclCompileErrorCmd(
PushLiteral(envPtr, "-code error -level 0", 20);
CompileWord(envPtr, messageTokenPtr, interp, 1);
TclEmitOpcode(INST_RETURN_STK, envPtr);
+ envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
@@ -2512,6 +2984,226 @@ PrintForeachInfo(
/*
*----------------------------------------------------------------------
*
+ * TclCompileFormatCmd --
+ *
+ * Procedure called to compile the "format" command. Handles cases that
+ * can be done as constants or simple string concatenation only.
+ *
+ * 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 "format" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileFormatCmd(
+ 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 = parsePtr->tokenPtr;
+ Tcl_Obj **objv, *formatObj, *tmpObj;
+ char *bytes, *start;
+ int i, j, len;
+
+ /*
+ * Don't handle any guaranteed-error cases.
+ */
+
+ if (parsePtr->numWords < 2) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Check if the argument words are all compile-time-known literals; that's
+ * a case we can handle by compiling to a constant.
+ */
+
+ formatObj = Tcl_NewObj();
+ Tcl_IncrRefCount(formatObj);
+ tokenPtr = TokenAfter(tokenPtr);
+ if (!TclWordKnownAtCompileTime(tokenPtr, formatObj)) {
+ Tcl_DecrRefCount(formatObj);
+ return TCL_ERROR;
+ }
+
+ objv = ckalloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *));
+ for (i=0 ; i+2 < parsePtr->numWords ; i++) {
+ tokenPtr = TokenAfter(tokenPtr);
+ objv[i] = Tcl_NewObj();
+ Tcl_IncrRefCount(objv[i]);
+ if (!TclWordKnownAtCompileTime(tokenPtr, objv[i])) {
+ goto checkForStringConcatCase;
+ }
+ }
+
+ /*
+ * Everything is a literal, so the result is constant too (or an error if
+ * the format is broken). Do the format now.
+ */
+
+ tmpObj = Tcl_Format(interp, Tcl_GetString(formatObj),
+ parsePtr->numWords-2, objv);
+ for (; --i>=0 ;) {
+ Tcl_DecrRefCount(objv[i]);
+ }
+ ckfree(objv);
+ Tcl_DecrRefCount(formatObj);
+ if (tmpObj == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Not an error, always a constant result, so just push the result as a
+ * literal. Job done.
+ */
+
+ bytes = Tcl_GetStringFromObj(tmpObj, &len);
+ PushLiteral(envPtr, bytes, len);
+ Tcl_DecrRefCount(tmpObj);
+ return TCL_OK;
+
+ checkForStringConcatCase:
+ /*
+ * See if we can generate a sequence of things to concatenate. This
+ * requires that all the % sequences be %s or %%, as everything else is
+ * sufficiently complex that we don't bother.
+ *
+ * First, get the state of the system relatively sensible (cleaning up
+ * after our attempt to spot a literal).
+ */
+
+ for (; --i>=0 ;) {
+ Tcl_DecrRefCount(objv[i]);
+ }
+ ckfree(objv);
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ tokenPtr = TokenAfter(tokenPtr);
+ i = 0;
+
+ /*
+ * Now scan through and check for non-%s and non-%% substitutions.
+ */
+
+ for (bytes = Tcl_GetString(formatObj) ; *bytes ; bytes++) {
+ if (*bytes == '%') {
+ bytes++;
+ if (*bytes == 's') {
+ i++;
+ continue;
+ } else if (*bytes == '%') {
+ continue;
+ }
+ Tcl_DecrRefCount(formatObj);
+ return TCL_ERROR;
+ }
+ }
+
+ /*
+ * Check if the number of things to concatenate will fit in a byte.
+ */
+
+ if (i+2 != parsePtr->numWords || i > 125) {
+ Tcl_DecrRefCount(formatObj);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Generate the pushes of the things to concatenate, a sequence of
+ * literals and compiled tokens (of which at least one is non-literal or
+ * we'd have the case in the first half of this function) which we will
+ * concatenate.
+ */
+
+ i = 0; /* The count of things to concat. */
+ j = 2; /* The index into the argument tokens, for
+ * TIP#280 handling. */
+ start = Tcl_GetString(formatObj);
+ /* The start of the currently-scanned literal
+ * in the format string. */
+ tmpObj = Tcl_NewObj(); /* The buffer used to accumulate the literal
+ * being built. */
+ for (bytes = start ; *bytes ; bytes++) {
+ if (*bytes == '%') {
+ Tcl_AppendToObj(tmpObj, start, bytes - start);
+ if (*++bytes == '%') {
+ Tcl_AppendToObj(tmpObj, "%", 1);
+ } else {
+ char *b = Tcl_GetStringFromObj(tmpObj, &len);
+
+ /*
+ * If there is a non-empty literal from the format string,
+ * push it and reset.
+ */
+
+ if (len > 0) {
+ PushLiteral(envPtr, b, len);
+ Tcl_DecrRefCount(tmpObj);
+ tmpObj = Tcl_NewObj();
+ i++;
+ }
+
+ /*
+ * Push the code to produce the string that would be
+ * substituted with %s, except we'll be concatenating
+ * directly.
+ */
+
+ CompileWord(envPtr, tokenPtr, interp, j);
+ tokenPtr = TokenAfter(tokenPtr);
+ j++;
+ i++;
+ }
+ start = bytes + 1;
+ }
+ }
+
+ /*
+ * Handle the case of a trailing literal.
+ */
+
+ Tcl_AppendToObj(tmpObj, start, bytes - start);
+ bytes = Tcl_GetStringFromObj(tmpObj, &len);
+ if (len > 0) {
+ PushLiteral(envPtr, bytes, len);
+ i++;
+ }
+ Tcl_DecrRefCount(tmpObj);
+ Tcl_DecrRefCount(formatObj);
+
+ if (i > 1) {
+ /*
+ * Do the concatenation, which produces the result.
+ */
+
+ TclEmitInstInt1(INST_CONCAT1, i, envPtr);
+ } else {
+ /*
+ * EVIL HACK! Force there to be a string representation in the case
+ * where there's just a "%s" in the format; case covered by the test
+ * format-20.1 (and it is horrible...)
+ */
+
+ TclEmitOpcode(INST_DUP, envPtr);
+ PushLiteral(envPtr, "", 0);
+ TclEmitOpcode(INST_STR_EQ, envPtr);
+ TclEmitOpcode(INST_POP, envPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompileGlobalCmd --
*
* Procedure called to compile the "global" command.
@@ -3022,22 +3714,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 +3863,118 @@ 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;
+}
+
+int
+TclCompileInfoObjectClassCmd(
+ 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 = TokenAfter(parsePtr->tokenPtr);
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ TclEmitOpcode( INST_TCLOO_CLASS, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileInfoObjectIsACmd(
+ 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 = TokenAfter(parsePtr->tokenPtr);
+
+ /*
+ * We only handle [info object isa object <somevalue>]. The first three
+ * words are compressed to a single token by the ensemble compilation
+ * engine.
+ */
+
+ if (parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size < 1
+ || strncmp(tokenPtr[1].start, "object", tokenPtr[1].size)) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+
+ /*
+ * Issue the code.
+ */
+
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ TclEmitOpcode( INST_TCLOO_IS_OBJECT, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileInfoObjectNamespaceCmd(
+ 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 = TokenAfter(parsePtr->tokenPtr);
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ TclEmitOpcode( INST_TCLOO_NS, envPtr);
+ return TCL_OK;
+}
/*
*----------------------------------------------------------------------
@@ -3936,11 +4823,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 +4841,154 @@ 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
+TclCompileNamespaceQualifiersCmd(
+ 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 = TokenAfter(parsePtr->tokenPtr);
+ DefineLineInformation; /* TIP #280 */
+ int off;
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ PushLiteral(envPtr, "0", 1);
+ PushLiteral(envPtr, "::", 2);
+ TclEmitInstInt4( INST_OVER, 2, envPtr);
+ TclEmitOpcode( INST_STR_FIND_LAST, envPtr);
+ off = CurrentOffset(envPtr);
+ PushLiteral(envPtr, "1", 1);
+ TclEmitOpcode( INST_SUB, envPtr);
+ TclEmitInstInt4( INST_OVER, 2, envPtr);
+ TclEmitInstInt4( INST_OVER, 1, envPtr);
+ TclEmitOpcode( INST_STR_INDEX, envPtr);
+ PushLiteral(envPtr, ":", 1);
+ TclEmitOpcode( INST_STR_EQ, envPtr);
+ off = off - CurrentOffset(envPtr);
+ TclEmitInstInt1( INST_JUMP_TRUE1, off, envPtr);
+ TclEmitOpcode( INST_STR_RANGE, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileNamespaceTailCmd(
+ 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 = TokenAfter(parsePtr->tokenPtr);
+ DefineLineInformation; /* TIP #280 */
+ JumpFixup jumpFixup;
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Take care; only add 2 to found index if the string was actually found.
+ */
+
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ PushLiteral(envPtr, "::", 2);
+ TclEmitInstInt4( INST_OVER, 1, envPtr);
+ TclEmitOpcode( INST_STR_FIND_LAST, envPtr);
+ TclEmitOpcode( INST_DUP, envPtr);
+ PushLiteral(envPtr, "0", 1);
+ TclEmitOpcode( INST_GE, envPtr);
+ TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFixup);
+ PushLiteral(envPtr, "2", 1);
+ TclEmitOpcode( INST_ADD, envPtr);
+ TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127);
+ PushLiteral(envPtr, "end", 3);
+ TclEmitOpcode( INST_STR_RANGE, 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 +5050,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;
+}
/*
*----------------------------------------------------------------------
@@ -4184,6 +5265,180 @@ TclCompileRegexpCmd(
/*
*----------------------------------------------------------------------
*
+ * TclCompileRegsubCmd --
+ *
+ * Procedure called to compile the "regsub" 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 "regsub" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileRegsubCmd(
+ Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the
+ * command. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds the resulting instructions. */
+{
+ /*
+ * We only compile the case with [regsub -all] where the pattern is both
+ * known at compile time and simple (i.e., no RE metacharacters). That is,
+ * the pattern must be translatable into a glob like "*foo*" with no other
+ * glob metacharacters inside it; there must be some "foo" in there too.
+ * The substitution string must also be known at compile time and free of
+ * metacharacters ("\digit" and "&"). Finally, there must not be a
+ * variable mentioned in the [regsub] to write the result back to (because
+ * we can't get the count of substitutions that would be the result in
+ * that case). The key is that these are the conditions under which a
+ * [string map] could be used instead, in particular a [string map] of the
+ * form we can compile to bytecode.
+ *
+ * In short, we look for:
+ *
+ * regsub -all [--] simpleRE string simpleReplacement
+ *
+ * The only optional part is the "--", and no other options are handled.
+ */
+
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr, *stringTokenPtr;
+ Tcl_Obj *patternObj = NULL, *replacementObj = NULL;
+ Tcl_DString pattern;
+ const char *bytes;
+ int len, exact, result = TCL_ERROR;
+
+ if (parsePtr->numWords < 5 || parsePtr->numWords > 6) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Parse the "-all", which must be the first argument (other options not
+ * supported, non-"-all" substitution we can't compile).
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 4
+ || strncmp(tokenPtr[1].start, "-all", 4)) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the pattern into patternObj, checking for "--" in the process.
+ */
+
+ Tcl_DStringInit(&pattern);
+ tokenPtr = TokenAfter(tokenPtr);
+ patternObj = Tcl_NewObj();
+ if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
+ goto done;
+ }
+ if (Tcl_GetString(patternObj)[0] == '-') {
+ if (strcmp(Tcl_GetString(patternObj), "--") != 0
+ || parsePtr->numWords == 5) {
+ goto done;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ Tcl_DecrRefCount(patternObj);
+ patternObj = Tcl_NewObj();
+ if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
+ goto done;
+ }
+ } else if (parsePtr->numWords == 6) {
+ goto done;
+ }
+
+ /*
+ * Identify the code which produces the string to apply the substitution
+ * to (stringTokenPtr), and the replacement string (into replacementObj).
+ */
+
+ stringTokenPtr = TokenAfter(tokenPtr);
+ tokenPtr = TokenAfter(stringTokenPtr);
+ replacementObj = Tcl_NewObj();
+ if (!TclWordKnownAtCompileTime(tokenPtr, replacementObj)) {
+ goto done;
+ }
+
+ /*
+ * Next, higher-level checks. Is the RE a very simple glob? Is the
+ * replacement "simple"?
+ */
+
+ bytes = Tcl_GetStringFromObj(patternObj, &len);
+ if (TclReToGlob(NULL, bytes, len, &pattern, &exact) != TCL_OK || exact) {
+ goto done;
+ }
+ bytes = Tcl_DStringValue(&pattern);
+ if (*bytes++ != '*') {
+ goto done;
+ }
+ while (1) {
+ switch (*bytes) {
+ case '*':
+ if (bytes[1] == '\0') {
+ /*
+ * OK, we've proved there are no metacharacters except for the
+ * '*' at each end.
+ */
+
+ len = Tcl_DStringLength(&pattern) - 2;
+ if (len > 0) {
+ goto isSimpleGlob;
+ }
+
+ /*
+ * The pattern is "**"! I believe that should be impossible,
+ * but we definitely can't handle that at all.
+ */
+ }
+ case '\0': case '?': case '[': case '\\':
+ goto done;
+ }
+ bytes++;
+ }
+ isSimpleGlob:
+ for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) {
+ switch (*bytes) {
+ case '\\': case '&':
+ goto done;
+ }
+ }
+
+ /*
+ * Proved the simplicity constraints! Time to issue the code.
+ */
+
+ result = TCL_OK;
+ bytes = Tcl_DStringValue(&pattern) + 1;
+ PushLiteral(envPtr, bytes, len);
+ bytes = Tcl_GetStringFromObj(replacementObj, &len);
+ PushLiteral(envPtr, bytes, len);
+ CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords-2);
+ TclEmitOpcode( INST_STR_MAP, envPtr);
+
+ done:
+ Tcl_DStringFree(&pattern);
+ if (patternObj) {
+ Tcl_DecrRefCount(patternObj);
+ }
+ if (replacementObj) {
+ Tcl_DecrRefCount(replacementObj);
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompileReturnCmd --
*
* Procedure called to compile the "return" command.
@@ -4216,6 +5471,7 @@ TclCompileReturnCmd(
int numWords = parsePtr->numWords;
int explicitResult = (0 == (numWords % 2));
int numOptionWords = numWords - 1 - explicitResult;
+ int savedStackDepth = envPtr->currStackDepth;
Tcl_Obj *returnOpts, **objv;
Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
DefineLineInformation; /* TIP #280 */
@@ -4238,6 +5494,7 @@ TclCompileReturnCmd(
CompileWord(envPtr, optsTokenPtr, interp, 2);
CompileWord(envPtr, msgTokenPtr, interp, 3);
TclEmitOpcode(INST_RETURN_STK, envPtr);
+ envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
@@ -4662,6 +5919,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..be63e0e 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -133,6 +133,8 @@ const AuxDataType tclJumptableInfoType = {
#define OP(name) TclEmitOpcode(INST_##name, envPtr)
#define OP1(name,val) TclEmitInstInt1(INST_##name,(val),envPtr)
#define OP4(name,val) TclEmitInstInt4(INST_##name,(val),envPtr)
+#define OP14(name,val1,val2) \
+ TclEmitInstInt1(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr)
#define OP44(name,val1,val2) \
TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr)
#define BODY(token,index) \
@@ -249,18 +251,18 @@ TclCompileSetCmd(
/*
*----------------------------------------------------------------------
*
- * TclCompileStringCmpCmd --
+ * TclCompileString*Cmd --
*
- * Procedure called to compile the simplest and most common form of the
- * "string compare" command.
+ * Procedures called to compile various subcommands of the "string"
+ * 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 "string compare"
- * command at runtime.
+ * Instructions are added to envPtr to execute the "string" command at
+ * runtime.
*
*----------------------------------------------------------------------
*/
@@ -296,25 +298,6 @@ TclCompileStringCmpCmd(
TclEmitOpcode(INST_STR_CMP, envPtr);
return TCL_OK;
}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileStringEqualCmd --
- *
- * Procedure called to compile the simplest and most common form of the
- * "string equal" 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 "string equal" command
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
int
TclCompileStringEqualCmd(
@@ -347,25 +330,70 @@ TclCompileStringEqualCmd(
TclEmitOpcode(INST_STR_EQ, envPtr);
return TCL_OK;
}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileStringIndexCmd --
- *
- * Procedure called to compile the simplest and most common form of the
- * "string index" 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 "string index" command
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
+
+int
+TclCompileStringFirstCmd(
+ 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;
+
+ /*
+ * We don't support any flags; the bytecode isn't that sophisticated.
+ */
+
+ if (parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Push the two operands onto the stack and then the test.
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ OP(STR_FIND);
+ return TCL_OK;
+}
+
+int
+TclCompileStringLastCmd(
+ 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;
+
+ /*
+ * We don't support any flags; the bytecode isn't that sophisticated.
+ */
+
+ if (parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Push the two operands onto the stack and then the test.
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ OP(STR_FIND_LAST);
+ return TCL_OK;
+}
int
TclCompileStringIndexCmd(
@@ -394,25 +422,6 @@ TclCompileStringIndexCmd(
TclEmitOpcode(INST_STR_INDEX, envPtr);
return TCL_OK;
}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileStringMatchCmd --
- *
- * Procedure called to compile the simplest and most common form of the
- * "string match" 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 "string match" command
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
int
TclCompileStringMatchCmd(
@@ -494,25 +503,6 @@ TclCompileStringMatchCmd(
}
return TCL_OK;
}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileStringLenCmd --
- *
- * Procedure called to compile the simplest and most common form of the
- * "string length" 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 "string length"
- * command at runtime.
- *
- *----------------------------------------------------------------------
- */
int
TclCompileStringLenCmd(
@@ -553,6 +543,158 @@ TclCompileStringLenCmd(
TclDecrRefCount(objPtr);
return TCL_OK;
}
+
+int
+TclCompileStringMapCmd(
+ 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 *mapTokenPtr, *stringTokenPtr;
+ Tcl_Obj *mapObj, **objv;
+ char *bytes;
+ int len;
+
+ /*
+ * We only handle the case:
+ *
+ * string map {foo bar} $thing
+ *
+ * That is, a literal two-element list (doesn't need to be brace-quoted,
+ * but does need to be compile-time knowable) and any old argument (the
+ * thing to map).
+ */
+
+ if (parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+ mapTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ stringTokenPtr = TokenAfter(mapTokenPtr);
+ mapObj = Tcl_NewObj();
+ Tcl_IncrRefCount(mapObj);
+ if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) {
+ Tcl_DecrRefCount(mapObj);
+ return TCL_ERROR;
+ } else if (Tcl_ListObjGetElements(NULL, mapObj, &len, &objv) != TCL_OK) {
+ Tcl_DecrRefCount(mapObj);
+ return TCL_ERROR;
+ } else if (len != 2) {
+ Tcl_DecrRefCount(mapObj);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Now issue the opcodes. Note that in the case that we know that the
+ * first word is an empty word, we don't issue the map at all. That is the
+ * correct semantics for mapping.
+ */
+
+ bytes = Tcl_GetStringFromObj(objv[0], &len);
+ if (len == 0) {
+ CompileWord(envPtr, stringTokenPtr, interp, 2);
+ } else {
+ PushLiteral(envPtr, bytes, len);
+ bytes = Tcl_GetStringFromObj(objv[1], &len);
+ PushLiteral(envPtr, bytes, len);
+ CompileWord(envPtr, stringTokenPtr, interp, 2);
+ OP(STR_MAP);
+ }
+ Tcl_DecrRefCount(mapObj);
+ return TCL_OK;
+}
+
+int
+TclCompileStringRangeCmd(
+ 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 *stringTokenPtr, *fromTokenPtr, *toTokenPtr;
+ Tcl_Obj *tmpObj;
+ int idx1, idx2, result;
+
+ if (parsePtr->numWords != 4) {
+ return TCL_ERROR;
+ }
+ stringTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ fromTokenPtr = TokenAfter(stringTokenPtr);
+ toTokenPtr = TokenAfter(fromTokenPtr);
+
+ /*
+ * Parse the first index. Will only compile if it is constant and not an
+ * _integer_ less than zero (since we reserve negative indices here for
+ * end-relative indexing).
+ */
+
+ tmpObj = Tcl_NewObj();
+ result = TCL_ERROR;
+ if (TclWordKnownAtCompileTime(fromTokenPtr, tmpObj)) {
+ if (TclGetIntFromObj(NULL, tmpObj, &idx1) == TCL_OK) {
+ if (idx1 >= 0) {
+ result = TCL_OK;
+ }
+ } else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx1) == TCL_OK) {
+ if (idx1 <= -2) {
+ result = TCL_OK;
+ }
+ }
+ }
+ TclDecrRefCount(tmpObj);
+ if (result != TCL_OK) {
+ goto nonConstantIndices;
+ }
+
+ /*
+ * Parse the second index. Will only compile if it is constant and not an
+ * _integer_ less than zero (since we reserve negative indices here for
+ * end-relative indexing).
+ */
+
+ tmpObj = Tcl_NewObj();
+ result = TCL_ERROR;
+ if (TclWordKnownAtCompileTime(toTokenPtr, tmpObj)) {
+ if (TclGetIntFromObj(NULL, tmpObj, &idx2) == TCL_OK) {
+ if (idx2 >= 0) {
+ result = TCL_OK;
+ }
+ } else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx2) == TCL_OK) {
+ if (idx2 <= -2) {
+ result = TCL_OK;
+ }
+ }
+ }
+ TclDecrRefCount(tmpObj);
+ if (result != TCL_OK) {
+ goto nonConstantIndices;
+ }
+
+ /*
+ * Push the operand onto the stack and then the substring operation.
+ */
+
+ CompileWord(envPtr, stringTokenPtr, interp, 1);
+ OP44( STR_RANGE_IMM, idx1, idx2);
+ return TCL_OK;
+
+ /*
+ * Push the operands onto the stack and then the substring operation.
+ */
+
+ nonConstantIndices:
+ CompileWord(envPtr, stringTokenPtr, interp, 1);
+ CompileWord(envPtr, fromTokenPtr, interp, 2);
+ CompileWord(envPtr, toTokenPtr, interp, 3);
+ OP( STR_RANGE);
+ return TCL_OK;
+}
/*
*----------------------------------------------------------------------
@@ -697,11 +839,11 @@ TclSubstCompile(
}
while (count > 255) {
- TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
+ OP1( CONCAT1, 255);
count -= 254;
}
if (count > 1) {
- TclEmitInstInt1(INST_CONCAT1, count, envPtr);
+ OP1( CONCAT1, count);
count = 1;
}
@@ -722,7 +864,7 @@ TclSubstCompile(
envPtr->line = bline;
catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
- TclEmitInstInt4(INST_BEGIN_CATCH4, catchRange, envPtr);
+ OP4( BEGIN_CATCH4, catchRange);
ExceptionRangeStarts(envPtr, catchRange);
switch (tokenPtr->type) {
@@ -743,20 +885,20 @@ TclSubstCompile(
ExceptionRangeEnds(envPtr, catchRange);
/* Substitution produced TCL_OK */
- TclEmitOpcode(INST_END_CATCH, envPtr);
+ OP( END_CATCH);
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &okFixup);
/* Exceptional return codes processed here */
ExceptionRangeTarget(envPtr, catchRange, catchOffset);
- TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr);
- TclEmitOpcode(INST_PUSH_RESULT, envPtr);
- TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
- TclEmitOpcode(INST_END_CATCH, envPtr);
- TclEmitOpcode(INST_RETURN_CODE_BRANCH, envPtr);
+ OP( PUSH_RETURN_OPTIONS);
+ OP( PUSH_RESULT);
+ OP( PUSH_RETURN_CODE);
+ OP( END_CATCH);
+ OP( RETURN_CODE_BRANCH);
/* ERROR -> reraise it */
- TclEmitOpcode(INST_RETURN_STK, envPtr);
- TclEmitOpcode(INST_NOP, envPtr);
+ OP( RETURN_STK);
+ OP( NOP);
/* RETURN */
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &returnFixup);
@@ -775,14 +917,14 @@ TclSubstCompile(
Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d",
(int) (CurrentOffset(envPtr) - breakFixup.codeOffset));
}
- TclEmitOpcode(INST_POP, envPtr);
- TclEmitOpcode(INST_POP, envPtr);
+ OP( POP);
+ OP( POP);
breakJump = CurrentOffset(envPtr) - breakOffset;
if (breakJump > 127) {
- TclEmitInstInt4(INST_JUMP4, -breakJump, envPtr);
+ OP4(JUMP4, -breakJump);
} else {
- TclEmitInstInt1(INST_JUMP1, -breakJump, envPtr);
+ OP1(JUMP1, -breakJump);
}
/* CONTINUE destination */
@@ -790,8 +932,8 @@ TclSubstCompile(
Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d",
(int) (CurrentOffset(envPtr) - continueFixup.codeOffset));
}
- TclEmitOpcode(INST_POP, envPtr);
- TclEmitOpcode(INST_POP, envPtr);
+ OP( POP);
+ OP( POP);
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup);
/* RETURN + other destination */
@@ -808,8 +950,8 @@ TclSubstCompile(
* Pull the result to top of stack, discard options dict.
*/
- TclEmitInstInt4(INST_REVERSE, 2, envPtr);
- TclEmitOpcode(INST_POP, envPtr);
+ OP4( REVERSE, 2);
+ OP( POP);
/*
* We've emitted several POP instructions, and the automatic
@@ -828,7 +970,7 @@ TclSubstCompile(
(int) (CurrentOffset(envPtr) - okFixup.codeOffset));
}
if (count > 1) {
- TclEmitInstInt1(INST_CONCAT1, count, envPtr);
+ OP1(CONCAT1, count);
count = 1;
}
@@ -840,13 +982,12 @@ TclSubstCompile(
bline = envPtr->line;
}
-
while (count > 255) {
- TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
+ OP1( CONCAT1, 255);
count -= 254;
}
if (count > 1) {
- TclEmitInstInt1(INST_CONCAT1, count, envPtr);
+ OP1( CONCAT1, count);
}
Tcl_FreeParse(&parse);
@@ -854,6 +995,7 @@ TclSubstCompile(
if (state != NULL) {
Tcl_RestoreInterpState(interp, state);
TclCompileSyntaxError(interp, envPtr);
+ TclAdjustStackDepth(-1, envPtr);
}
/* Final target of the multi-jump from all BREAKs */
@@ -1277,14 +1419,14 @@ IssueSwitchChainedTests(
switch (mode) {
case Switch_Exact:
- TclEmitOpcode(INST_DUP, envPtr);
+ OP( DUP);
TclCompileTokens(interp, bodyToken[i], 1, envPtr);
- TclEmitOpcode(INST_STR_EQ, envPtr);
+ OP( STR_EQ);
break;
case Switch_Glob:
TclCompileTokens(interp, bodyToken[i], 1, envPtr);
- TclEmitInstInt4(INST_OVER, 1, envPtr);
- TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr);
+ OP4( OVER, 1);
+ OP1( STR_MATCH, noCase);
break;
case Switch_Regexp:
simple = exact = 0;
@@ -1323,7 +1465,7 @@ IssueSwitchChainedTests(
TclCompileTokens(interp, bodyToken[i], 1, envPtr);
}
- TclEmitInstInt4(INST_OVER, 1, envPtr);
+ OP4( OVER, 1);
if (!simple) {
/*
* Pass correct RE compile flags. We use only Int1
@@ -1335,11 +1477,11 @@ IssueSwitchChainedTests(
int cflags = TCL_REG_ADVANCED
| (noCase ? TCL_REG_NOCASE : 0);
- TclEmitInstInt1(INST_REGEXP, cflags, envPtr);
+ OP1(REGEXP, cflags);
} else if (exact && !noCase) {
- TclEmitOpcode(INST_STR_EQ, envPtr);
+ OP( STR_EQ);
} else {
- TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr);
+ OP1(STR_MATCH, noCase);
}
break;
default:
@@ -1404,7 +1546,7 @@ IssueSwitchChainedTests(
* pattern.
*/
- TclEmitOpcode(INST_POP, envPtr);
+ OP( POP);
envPtr->currStackDepth = savedStackDepth + 1;
envPtr->line = bodyLines[i+1]; /* TIP #280 */
envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */
@@ -1426,7 +1568,7 @@ IssueSwitchChainedTests(
*/
if (!foundDefault) {
- TclEmitOpcode(INST_POP, envPtr);
+ OP( POP);
PushLiteral(envPtr, "", 0);
}
@@ -1498,6 +1640,7 @@ IssueSwitchJumpTable(
int **bodyContLines) /* Array of continuation line info. */
{
JumptableInfo *jtPtr;
+ int savedStackDepth = envPtr->currStackDepth;
int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation;
int mustGenerate, foundDefault, jumpToDefault, i;
Tcl_DString buffer;
@@ -1537,9 +1680,9 @@ IssueSwitchJumpTable(
*/
jumpLocation = CurrentOffset(envPtr);
- TclEmitInstInt4(INST_JUMP_TABLE, infoIndex, envPtr);
+ OP4( JUMP_TABLE, infoIndex);
jumpToDefault = CurrentOffset(envPtr);
- TclEmitInstInt4(INST_JUMP4, 0, envPtr);
+ OP4( JUMP4, 0);
for (i=0 ; i<numBodyTokens ; i+=2) {
/*
@@ -1610,6 +1753,7 @@ IssueSwitchJumpTable(
* Compile the body of the arm.
*/
+ envPtr->currStackDepth = savedStackDepth;
envPtr->line = bodyLines[i+1]; /* TIP #280 */
envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */
TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
@@ -1630,7 +1774,7 @@ IssueSwitchJumpTable(
* rewriting when we fixed this all up.
*/
- TclEmitInstInt4(INST_JUMP4, 0, envPtr);
+ OP4( JUMP4, 0);
}
}
@@ -1641,6 +1785,7 @@ IssueSwitchJumpTable(
*/
if (!foundDefault) {
+ envPtr->currStackDepth = savedStackDepth;
TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault,
envPtr->codeStart+jumpToDefault+1);
PushLiteral(envPtr, "", 0);
@@ -1661,6 +1806,7 @@ IssueSwitchJumpTable(
*/
TclStackFree(interp, finalFixups);
+ envPtr->currStackDepth = savedStackDepth + 1;
}
/*
@@ -1746,6 +1892,50 @@ PrintJumptableInfo(
/*
*----------------------------------------------------------------------
*
+ * TclCompileTailcallCmd --
+ *
+ * Procedure called to compile the "tailcall" 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 "tailcall" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileTailcallCmd(
+ 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 = parsePtr->tokenPtr;
+ int i;
+
+ if (parsePtr->numWords < 2 || parsePtr->numWords > 256
+ || envPtr->procPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ for (i=1 ; i<parsePtr->numWords ; i++) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, i);
+ }
+ TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords-1, envPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompileThrowCmd --
*
* Procedure called to compile the "throw" command.
@@ -1772,6 +1962,7 @@ TclCompileThrowCmd(
{
DefineLineInformation; /* TIP #280 */
int numWords = parsePtr->numWords;
+ int savedStackDepth = envPtr->currStackDepth;
Tcl_Token *codeToken, *msgToken;
Tcl_Obj *objPtr;
@@ -1802,6 +1993,7 @@ TclCompileThrowCmd(
CompileWord(envPtr, msgToken, interp, 2);
TclCompileSyntaxError(interp, envPtr);
Tcl_DecrRefCount(objPtr);
+ envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
if (len == 0) {
@@ -1822,6 +2014,7 @@ TclCompileThrowCmd(
PushLiteral(envPtr, string, len);
TclDecrRefCount(dictPtr);
OP44( RETURN_IMM, 1, 0);
+ envPtr->currStackDepth = savedStackDepth + 1;
} else {
/*
* When the code token is not known at compilation time, we need to do
@@ -1850,6 +2043,7 @@ TclCompileThrowCmd(
PUSH( "");
OP44( RETURN_IMM, 1, 0);
}
+ envPtr->currStackDepth = savedStackDepth + 1;
TclDecrRefCount(objPtr);
return TCL_OK;
}
@@ -2117,6 +2311,7 @@ IssueTryInstructions(
{
DefineLineInformation; /* TIP #280 */
int range, resultVar, optionsVar;
+ int savedStackDepth = envPtr->currStackDepth;
int i, j, len, forwardsNeedFixing = 0;
int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
char buf[TCL_INTEGER_SPACE];
@@ -2178,6 +2373,7 @@ IssueTryInstructions(
LOAD( optionsVar);
PUSH( "-errorcode");
OP4( DICT_GET, 1);
+ TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
PUSH( TclGetString(matchClauses[i]));
OP( STR_EQ);
@@ -2218,6 +2414,7 @@ IssueTryInstructions(
forwardsToFix[j] = -1;
}
}
+ envPtr->currStackDepth = savedStackDepth;
BODY( handlerTokens[i], 5+i*4);
}
@@ -2249,6 +2446,7 @@ IssueTryInstructions(
}
TclStackFree(interp, forwardsToFix);
TclStackFree(interp, addrsToFix);
+ envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
@@ -2285,6 +2483,7 @@ IssueTryFinallyInstructions(
range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
OP4( BEGIN_CATCH4, range);
ExceptionRangeStarts(envPtr, range);
+ envPtr->currStackDepth = savedStackDepth;
BODY( bodyToken, 1);
ExceptionRangeEnds(envPtr, range);
PUSH( "0");
@@ -2329,6 +2528,7 @@ IssueTryFinallyInstructions(
LOAD( optionsVar);
PUSH( "-errorcode");
OP4( DICT_GET, 1);
+ TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
PUSH( TclGetString(matchClauses[i]));
OP( STR_EQ);
@@ -2401,6 +2601,7 @@ IssueTryFinallyInstructions(
}
OP4( BEGIN_CATCH4, range);
}
+ envPtr->currStackDepth = savedStackDepth;
BODY( handlerTokens[i], 5+i*4);
ExceptionRangeEnds(envPtr, range);
OP( PUSH_RETURN_OPTIONS);
@@ -2452,7 +2653,6 @@ IssueTryFinallyInstructions(
*/
OP( POP);
- envPtr->currStackDepth = savedStackDepth;
/*
* Process the finally clause (at last!) Note that we do not wrap this in
@@ -2462,11 +2662,13 @@ IssueTryFinallyInstructions(
* next command (or some inter-command manipulation).
*/
+ envPtr->currStackDepth = savedStackDepth;
BODY( finallyToken, 3 + 4*numHandlers);
OP( POP);
LOAD( optionsVar);
LOAD( resultVar);
OP( RETURN_STK);
+ envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
@@ -2547,20 +2749,18 @@ TclCompileUnsetCmd(
*/
if (!simpleVarName) {
- TclEmitInstInt1( INST_UNSET_STK, flags, envPtr);
+ OP1( UNSET_STK, flags);
} else if (isScalar) {
if (localIndex < 0) {
- TclEmitInstInt1(INST_UNSET_STK, flags, envPtr);
+ OP1( UNSET_STK, flags);
} else {
- TclEmitInstInt1(INST_UNSET_SCALAR, flags, envPtr);
- TclEmitInt4( localIndex, envPtr);
+ OP14( UNSET_SCALAR, flags, localIndex);
}
} else {
if (localIndex < 0) {
- TclEmitInstInt1(INST_UNSET_ARRAY_STK, flags, envPtr);
+ OP1( UNSET_ARRAY_STK, flags);
} else {
- TclEmitInstInt1(INST_UNSET_ARRAY, flags, envPtr);
- TclEmitInt4( localIndex, envPtr);
+ OP14( UNSET_ARRAY, flags, localIndex);
}
}
@@ -2697,7 +2897,7 @@ TclCompileWhileCmd(
CompileBody(envPtr, bodyTokenPtr, interp);
ExceptionRangeEnds(envPtr, range);
envPtr->currStackDepth = savedStackDepth + 1;
- TclEmitOpcode(INST_POP, envPtr);
+ OP( POP);
/*
* Compile the test expression then emit the conditional jump that
@@ -2752,6 +2952,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);
+ }
+ OP( YIELD);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* PushVarName --
*
* Procedure used in the compiling where pushing a variable name is
@@ -3074,7 +3317,7 @@ CompileAssociativeBinaryOpCmd(
* calcuations, including roundoff errors.
*/
- TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
+ OP4( REVERSE, words-1);
}
while (--words > 1) {
TclEmitOpcode(instruction, envPtr);
@@ -3165,31 +3408,19 @@ CompileComparisonOpCmd(
CompileWord(envPtr, tokenPtr, interp, 1);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
- if (tmpIndex <= 255) {
- TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
- }
+ STORE(tmpIndex);
TclEmitOpcode(instruction, envPtr);
for (words=3 ; words<parsePtr->numWords ;) {
- if (tmpIndex <= 255) {
- TclEmitInstInt1(INST_LOAD_SCALAR1, tmpIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr);
- }
+ LOAD(tmpIndex);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, words);
if (++words < parsePtr->numWords) {
- if (tmpIndex <= 255) {
- TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
- }
+ STORE(tmpIndex);
}
TclEmitOpcode(instruction, envPtr);
}
for (; words>3 ; words--) {
- TclEmitOpcode(INST_BITAND, envPtr);
+ OP( BITAND);
}
/*
@@ -3197,13 +3428,7 @@ CompileComparisonOpCmd(
* might be expensive elsewhere.
*/
- PushLiteral(envPtr, "", 0);
- if (tmpIndex <= 255) {
- TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
- }
- TclEmitOpcode(INST_POP, envPtr);
+ OP14( UNSET_SCALAR, 0, tmpIndex);
}
return TCL_OK;
}
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index d4ca284..309682d 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
@@ -372,13 +372,13 @@ InstructionDesc const tclInstructionTable[] = {
* Stack: ... value => ...
* Note that the jump table contains offsets relative to the PC when
* it points to this instruction; the code is relocatable. */
- {"upvar", 5, 0, 1, {OPERAND_LVT4}},
+ {"upvar", 5, -1, 1, {OPERAND_LVT4}},
/* finds level and otherName in stack, links to local variable at
* index op1. Leaves the level on stack. */
- {"nsupvar", 5, 0, 1, {OPERAND_LVT4}},
+ {"nsupvar", 5, -1, 1, {OPERAND_LVT4}},
/* finds namespace and otherName in stack, links to local variable at
* index op1. Leaves the namespace on stack. */
- {"variable", 5, 0, 1, {OPERAND_LVT4}},
+ {"variable", 5, -1, 1, {OPERAND_LVT4}},
/* finds namespace and otherName in stack, links to local variable at
* index op1. Leaves the namespace on stack. */
{"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}},
@@ -434,6 +434,100 @@ InstructionDesc const tclInstructionTable[] = {
/* Map variable contents back into a dictionary in the local variable
* indicated by the LVT index. Part of [dict with].
* Stack: ... path keyList => ... */
+ {"dictExists", 5, INT_MIN, 1, {OPERAND_UINT4}},
+ /* The top op4 words (min 1) are a key path into the dictionary just
+ * below the keys on the stack, and all those values are replaced by a
+ * boolean indicating whether it is possible to read out a value from
+ * that key-path (like [dict exists]).
+ * Stack: ... dict key1 ... keyN => ... boolean */
+ {"verifyDict", 1, -1, 0, {OPERAND_NONE}},
+ /* Verifies that the word on the top of the stack is a dictionary,
+ * popping it if it is and throwing an error if it is not.
+ * Stack: ... value => ... */
+
+ {"strmap", 1, -2, 0, {OPERAND_NONE}},
+ /* Simplified version of [string map] that only applies one change
+ * string, and only case-sensitively.
+ * Stack: ... from to string => ... changedString */
+ {"strfind", 1, -1, 0, {OPERAND_NONE}},
+ /* Find the first index of a needle string in a haystack string,
+ * producing the index (integer) or -1 if nothing found.
+ * Stack: ... needle haystack => ... index */
+ {"strrfind", 1, -1, 0, {OPERAND_NONE}},
+ /* Find the last index of a needle string in a haystack string,
+ * producing the index (integer) or -1 if nothing found.
+ * Stack: ... needle haystack => ... index */
+ {"strrangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}},
+ /* String Range: push (string range stktop op4 op4) */
+ {"strrange", 1, -2, 0, {OPERAND_NONE}},
+ /* String Range with non-constant arguments.
+ * Stack: ... string idxA idxB => ... substring */
+
+ {"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. */
+ {"tailcall", 2, INT_MIN, 1, {OPERAND_UINT1}},
+ /* Do a tailcall with the opnd items on the stack as the thing to
+ * tailcall to; opnd must be greater than 0 for the semantics to work
+ * right. */
+
+ {"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. */
+ {"tclooClass", 1, 0, 0, {OPERAND_NONE}},
+ /* Push the class of the TclOO object named at the top of the stack
+ * onto the stack.
+ * Stack: ... object => ... class */
+ {"tclooNamespace", 1, 0, 0, {OPERAND_NONE}},
+ /* Push the namespace of the TclOO object named at the top of the
+ * stack onto the stack.
+ * Stack: ... object => ... namespace */
+ {"tclooIsObject", 1, 0, 0, {OPERAND_NONE}},
+ /* Push whether the value named at the top of the stack is a TclOO
+ * object (i.e., a boolean). Can corrupt the interpreter result
+ * despite not throwing, so not safe for use in a post-exception
+ * context.
+ * Stack: ... value => ... boolean */
+
+ {"arrayExistsStk", 1, 0, 0, {OPERAND_NONE}},
+ /* Looks up the element on the top of the stack and tests whether it
+ * is an array. Pushes a boolean describing whether this is the
+ * case. Also runs the whole-array trace on the named variable, so can
+ * throw anything.
+ * Stack: ... varName => ... boolean */
+ {"arrayExistsImm", 5, +1, 1, {OPERAND_UINT4}},
+ /* Looks up the variable indexed by opnd and tests whether it is an
+ * array. Pushes a boolean describing whether this is the case. Also
+ * runs the whole-array trace on the named variable, so can throw
+ * anything.
+ * Stack: ... => ... boolean */
+ {"arrayMakeStk", 1, -1, 0, {OPERAND_NONE}},
+ /* Forces the element on the top of the stack to be the name of an
+ * array.
+ * Stack: ... varName => ... */
+ {"arrayMakeImm", 5, 0, 1, {OPERAND_UINT4}},
+ /* Forces the variable indexed by opnd to be an array. Does not touch
+ * the stack. */
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
@@ -1673,10 +1767,13 @@ 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;
+#ifdef TCL_COMPILE_DEBUG
+ int startStackDepth = envPtr->currStackDepth;
+#endif
/*
* Mark the start of the command; the proper bytecode
@@ -1720,6 +1817,25 @@ TclCompileScript(
envPtr);
if (code == TCL_OK) {
+ /*
+ * Confirm that the command compiler generated a
+ * single value on the stack as its result. This
+ * is only done in debugging mode, as it *should*
+ * be correct and normal users have no reasonable
+ * way to fix it anyway.
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+ int diff = envPtr->currStackDepth-startStackDepth;
+
+ if (diff != 1 && (diff != 0 ||
+ *(envPtr->codeNext-1) != INST_DONE)) {
+ Tcl_Panic("bad stack adjustment when compiling"
+ " %.*s (was %d instead of 1)",
+ parsePtr->tokenPtr->size,
+ parsePtr->tokenPtr->start, diff);
+ }
+#endif
if (update) {
/*
* Fix the bytecode length.
@@ -4620,6 +4736,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..3302f9b 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -676,13 +676,43 @@ typedef struct ByteCode {
#define INST_UNSET_ARRAY_STK 136
#define INST_UNSET_STK 137
-/* For [dict with] compilation */
+/* For [dict with], [dict exists], [dict create] and [dict merge] */
#define INST_DICT_EXPAND 138
#define INST_DICT_RECOMBINE_STK 139
#define INST_DICT_RECOMBINE_IMM 140
+#define INST_DICT_EXISTS 141
+#define INST_DICT_VERIFY 142
+
+/* For [string map] and [regsub] compilation */
+#define INST_STR_MAP 143
+#define INST_STR_FIND 144
+#define INST_STR_FIND_LAST 145
+#define INST_STR_RANGE_IMM 146
+#define INST_STR_RANGE 147
+
+/* For operations to do with coroutines and other NRE-manipulators */
+#define INST_YIELD 148
+#define INST_COROUTINE_NAME 149
+#define INST_TAILCALL 150
+
+/* For compilation of basic information operations */
+#define INST_NS_CURRENT 151
+#define INST_INFO_LEVEL_NUM 152
+#define INST_INFO_LEVEL_ARGS 153
+#define INST_RESOLVE_COMMAND 154
+#define INST_TCLOO_SELF 155
+#define INST_TCLOO_CLASS 156
+#define INST_TCLOO_NS 157
+#define INST_TCLOO_IS_OBJECT 158
+
+/* For compilation of [array] subcommands */
+#define INST_ARRAY_EXISTS_STK 159
+#define INST_ARRAY_EXISTS_IMM 160
+#define INST_ARRAY_MAKE_STK 161
+#define INST_ARRAY_MAKE_IMM 162
/* The last opcode */
-#define LAST_INST_OPCODE 140
+#define LAST_INST_OPCODE 162
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index ea9411c..eb3625e 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -89,8 +89,8 @@ static int DictMapLoopCallback(ClientData data[],
static const EnsembleImplMap implementationMap[] = {
{"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 },
- {"create", DictCreateCmd, NULL, NULL, NULL, 0 },
- {"exists", DictExistsCmd, NULL, NULL, NULL, 0 },
+ {"create", DictCreateCmd, TclCompileDictCreateCmd, NULL, NULL, 0 },
+ {"exists", DictExistsCmd, TclCompileDictExistsCmd, NULL, NULL, 0 },
{"filter", DictFilterCmd, NULL, NULL, NULL, 0 },
{"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 },
{"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 },
@@ -99,7 +99,7 @@ static const EnsembleImplMap implementationMap[] = {
{"keys", DictKeysCmd, NULL, NULL, NULL, 0 },
{"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 },
{"map", NULL, TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 },
- {"merge", DictMergeCmd, NULL, NULL, NULL, 0 },
+ {"merge", DictMergeCmd, TclCompileDictMergeCmd, NULL, NULL, 0 },
{"remove", DictRemoveCmd, NULL, NULL, NULL, 0 },
{"replace", DictReplaceCmd, NULL, NULL, NULL, 0 },
{"set", DictSetCmd, TclCompileDictSetCmd, NULL, NULL, 0 },
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 3c0b472..caf35ba 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,101 @@ 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_TAILCALL: {
+ Tcl_Obj *listPtr, *nsObjPtr;
+ NRE_callback *tailcallPtr;
+
+ opnd = TclGetUInt1AtPtr(pc+1);
+
+ if (!(iPtr->varFramePtr->isProcCallFrame & 1)) {
+ TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "tailcall can only be called from a proc or lambda", -1));
+ Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
+ goto gotError;
+ }
+
+#ifdef TCL_COMPILE_DEBUG
+ {
+ register int i;
+
+ TRACE(("%d [", opnd));
+ for (i=opnd-1 ; i>=0 ; i++) {
+ TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i))));
+ if (i > 0) {
+ TRACE_APPEND((" "));
+ }
+ }
+ TRACE_APPEND(("] => RETURN..."));
+ }
+#endif
+
+ /*
+ * Push the evaluation of the called command into the NR callback
+ * stack.
+ */
+
+ listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1));
+ nsObjPtr = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName, -1);
+ Tcl_IncrRefCount(listPtr);
+ Tcl_IncrRefCount(nsObjPtr);
+ TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr,
+ NULL, NULL);
+
+ /*
+ * Unstitch ourselves and do a [return].
+ */
+
+ tailcallPtr = TOP_CB(interp);
+ TOP_CB(interp) = tailcallPtr->nextPtr;
+ iPtr->varFramePtr->tailcallPtr = tailcallPtr;
+ result = TCL_RETURN;
+ cleanup = opnd;
+ goto processExceptionReturn;
+ }
+
case INST_DONE:
if (tosPtr > initTosPtr) {
/*
@@ -3785,6 +3881,104 @@ TEBCresume(
/*
* End of INST_UNSET instructions.
* -----------------------------------------------------------------
+ * Start of INST_ARRAY instructions.
+ */
+
+ case INST_ARRAY_EXISTS_IMM:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ pcAdjustment = 5;
+ cleanup = 0;
+ part1Ptr = NULL;
+ arrayPtr = NULL;
+ TRACE(("%u => ", opnd));
+ varPtr = LOCAL(opnd);
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ goto doArrayExists;
+ case INST_ARRAY_EXISTS_STK:
+ opnd = -1;
+ pcAdjustment = 1;
+ cleanup = 1;
+ part1Ptr = OBJ_AT_TOS;
+ TRACE(("\"%.30s\" => ", O2S(part1Ptr)));
+ varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL,
+ /*createPart1*/0, /*createPart2*/0, &arrayPtr);
+ doArrayExists:
+ if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
+ && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
+ DECACHE_STACK_INFO();
+ result = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr,
+ NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|
+ TCL_GLOBAL_ONLY|TCL_TRACE_ARRAY), 1, opnd);
+ CACHE_STACK_INFO();
+ if (result == TCL_ERROR) {
+ TRACE_APPEND(("ERROR: %.30s\n",
+ O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ }
+ }
+ if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
+ objResultPtr = TCONST(1);
+ } else {
+ objResultPtr = TCONST(0);
+ }
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(pcAdjustment, cleanup, 1);
+
+ case INST_ARRAY_MAKE_IMM:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ pcAdjustment = 5;
+ cleanup = 0;
+ part1Ptr = NULL;
+ arrayPtr = NULL;
+ TRACE(("%u => ", opnd));
+ varPtr = LOCAL(opnd);
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ goto doArrayMake;
+ case INST_ARRAY_MAKE_STK:
+ opnd = -1;
+ pcAdjustment = 1;
+ cleanup = 1;
+ part1Ptr = OBJ_AT_TOS;
+ TRACE(("\"%.30s\" => ", O2S(part1Ptr)));
+ varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, TCL_LEAVE_ERR_MSG,
+ "set", /*createPart1*/1, /*createPart2*/0, &arrayPtr);
+ if (varPtr == NULL) {
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ }
+ doArrayMake:
+ if (varPtr && !TclIsVarArray(varPtr)) {
+ if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) {
+ /*
+ * Either an array element, or a scalar: lose!
+ */
+
+ TclObjVarErrMsg(interp, part1Ptr, NULL, "array set",
+ "variable isn't array", opnd);
+ Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL);
+ TRACE_APPEND(("ERROR: bad array ref: %.30s\n",
+ O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ }
+ TclSetVarArray(varPtr);
+ varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable));
+ TclInitVarHashTable(varPtr->value.tablePtr,
+ TclGetVarNsPtr(varPtr));
+#ifdef TCL_COMPILE_DEBUG
+ TRACE_APPEND(("done\n"));
+ } else {
+ TRACE_APPEND(("nothing to do\n"));
+#endif
+ }
+ NEXT_INST_V(pcAdjustment, cleanup, 0);
+
+ /*
+ * End of INST_ARRAY instructions.
+ * -----------------------------------------------------------------
* Start of variable linking instructions.
*/
@@ -4045,6 +4239,136 @@ 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);
+ }
+ {
+ Object *oPtr;
+
+ case INST_TCLOO_IS_OBJECT:
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS);
+ objResultPtr = TCONST(oPtr != NULL ? 1 : 0);
+ TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr);
+ NEXT_INST_F(1, 1, 1);
+ case INST_TCLOO_CLASS:
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS);
+ if (oPtr == NULL) {
+ TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS)));
+ goto gotError;
+ }
+ objResultPtr = TclOOObjectName(interp, oPtr->selfCls->thisPtr);
+ TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr);
+ NEXT_INST_F(1, 1, 1);
+ case INST_TCLOO_NS:
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS);
+ if (oPtr == NULL) {
+ TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS)));
+ goto gotError;
+ }
+
+ /*
+ * TclOO objects *never* have the global namespace as their NS.
+ */
+
+ TclNewStringObj(objResultPtr, oPtr->namespacePtr->fullName,
+ strlen(oPtr->namespacePtr->fullName));
+ TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr);
+ NEXT_INST_F(1, 1, 1);
+ }
+
+ /*
+ * -----------------------------------------------------------------
* Start of INST_LIST and related instructions.
*/
@@ -4592,6 +4916,179 @@ TEBCresume(
O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
+ case INST_STR_RANGE:
+ TRACE(("\"%.20s\" %s %s =>",
+ O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS)));
+ length = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1;
+ if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length,
+ &fromIdx) != TCL_OK
+ || TclGetIntForIndexM(interp, OBJ_AT_TOS, length,
+ &toIdx) != TCL_OK) {
+ goto gotError;
+ }
+
+ if (fromIdx < 0) {
+ fromIdx = 0;
+ }
+ if (toIdx >= length) {
+ toIdx = length;
+ }
+ if (toIdx >= fromIdx) {
+ objResultPtr = Tcl_GetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx);
+ } else {
+ TclNewObj(objResultPtr);
+ }
+ TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
+ NEXT_INST_V(1, 3, 1);
+
+ case INST_STR_RANGE_IMM:
+ valuePtr = OBJ_AT_TOS;
+ fromIdx = TclGetInt4AtPtr(pc+1);
+ toIdx = TclGetInt4AtPtr(pc+5);
+ length = Tcl_GetCharLength(valuePtr);
+ TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx));
+
+ /*
+ * Adjust indices for end-based indexing.
+ */
+
+ if (fromIdx < -1) {
+ fromIdx += 1 + length;
+ if (fromIdx < 0) {
+ fromIdx = 0;
+ }
+ } else if (fromIdx >= length) {
+ fromIdx = length;
+ }
+ if (toIdx < -1) {
+ toIdx += 1 + length;
+ if (toIdx < 0) {
+ toIdx = 0;
+ }
+ } else if (toIdx >= length) {
+ toIdx = length - 1;
+ }
+
+ /*
+ * Check if we can do a sane substring.
+ */
+
+ if (fromIdx <= toIdx) {
+ objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx);
+ } else {
+ TclNewObj(objResultPtr);
+ }
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_F(9, 1, 1);
+
+ {
+ Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p;
+ int length3;
+ Tcl_Obj *value3Ptr;
+
+ case INST_STR_MAP:
+ valuePtr = OBJ_AT_TOS; /* "Main" string. */
+ value3Ptr = OBJ_UNDER_TOS; /* "Target" string. */
+ value2Ptr = OBJ_AT_DEPTH(2); /* "Source" string. */
+ if (value3Ptr == value2Ptr) {
+ objResultPtr = valuePtr;
+ NEXT_INST_V(1, 3, 1);
+ } else if (valuePtr == value2Ptr) {
+ objResultPtr = value3Ptr;
+ NEXT_INST_V(1, 3, 1);
+ }
+ ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
+ if (length == 0) {
+ objResultPtr = valuePtr;
+ NEXT_INST_V(1, 3, 1);
+ }
+ ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
+ if (length2 > length || length2 == 0) {
+ objResultPtr = valuePtr;
+ NEXT_INST_V(1, 3, 1);
+ } else if (length2 == length) {
+ if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length)) {
+ objResultPtr = valuePtr;
+ } else {
+ objResultPtr = value3Ptr;
+ }
+ NEXT_INST_V(1, 3, 1);
+ }
+ ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3);
+
+ objResultPtr = Tcl_NewUnicodeObj(ustring1, 0);
+ p = ustring1;
+ end = ustring1 + length;
+ for (; ustring1 < end; ustring1++) {
+ if ((*ustring1 == *ustring2) && (length2==1 ||
+ memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2)
+ == 0)) {
+ if (p != ustring1) {
+ Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p);
+ p = ustring1 + length2;
+ } else {
+ p += length2;
+ }
+ ustring1 = p - 1;
+
+ Tcl_AppendUnicodeToObj(objResultPtr, ustring3, length3);
+ }
+ }
+ if (p != ustring1) {
+ /*
+ * Put the rest of the unmapped chars onto result.
+ */
+
+ Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p);
+ }
+ TRACE_WITH_OBJ(("%.20s %.20s %.20s => ",
+ O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr);
+ NEXT_INST_V(1, 3, 1);
+
+ case INST_STR_FIND:
+ ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */
+ ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */
+
+ match = -1;
+ if (length2 > 0 && length2 <= length) {
+ end = ustring1 + length - length2 + 1;
+ for (p=ustring1 ; p<end ; p++) {
+ if ((*p == *ustring2) &&
+ memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) {
+ match = p - ustring1;
+ break;
+ }
+ }
+ }
+
+ TRACE(("%.20s %.20s => %d\n",
+ O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match));
+
+ TclNewIntObj(objResultPtr, match);
+ NEXT_INST_F(1, 2, 1);
+
+ case INST_STR_FIND_LAST:
+ ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */
+ ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */
+
+ match = -1;
+ if (length2 > 0 && length2 <= length) {
+ for (p=ustring1+length-length2 ; p>=ustring1 ; p--) {
+ if ((*p == *ustring2) &&
+ memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) {
+ match = p - ustring1;
+ break;
+ }
+ }
+ }
+
+ TRACE(("%.20s %.20s => %d\n",
+ O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match));
+
+ TclNewIntObj(objResultPtr, match);
+ NEXT_INST_F(1, 2, 1);
+ }
+
case INST_STR_MATCH:
nocase = TclGetInt1AtPtr(pc+1);
valuePtr = OBJ_AT_TOS; /* String */
@@ -5648,23 +6145,48 @@ TEBCresume(
Tcl_DictSearch *searchPtr;
DictUpdateInfo *duiPtr;
+ case INST_DICT_VERIFY:
+ dictPtr = OBJ_AT_TOS;
+ TRACE(("=> "));
+ if (Tcl_DictObjSize(interp, dictPtr, &done) != TCL_OK) {
+ TRACE_APPEND(("ERROR verifying dictionary nature of \"%s\": %s\n",
+ O2S(OBJ_AT_DEPTH(opnd)), O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ }
+ TRACE_APPEND(("OK\n"));
+ NEXT_INST_F(1, 1, 0);
+
case INST_DICT_GET:
+ case INST_DICT_EXISTS: {
+ register Tcl_Interp *interp2 = interp;
+
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
dictPtr = OBJ_AT_DEPTH(opnd);
+ if (*pc == INST_DICT_EXISTS) {
+ interp2 = NULL;
+ }
if (opnd > 1) {
- dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1,
+ dictPtr = TclTraceDictPath(interp2, dictPtr, opnd-1,
&OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ);
if (dictPtr == NULL) {
+ if (*pc == INST_DICT_EXISTS) {
+ goto dictNotExists;
+ }
TRACE_WITH_OBJ((
- "%u => ERROR tracing dictionary path into \"%s\": ",
- opnd, O2S(OBJ_AT_DEPTH(opnd))),
+ "ERROR tracing dictionary path into \"%s\": ",
+ O2S(OBJ_AT_DEPTH(opnd))),
Tcl_GetObjResult(interp));
goto gotError;
}
}
- if (Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS,
+ if (Tcl_DictObjGet(interp2, dictPtr, OBJ_AT_TOS,
&objResultPtr) == TCL_OK) {
+ if (*pc == INST_DICT_EXISTS) {
+ objResultPtr = TCONST(objResultPtr ? 1 : 0);
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(5, opnd+1, 1);
+ }
if (objResultPtr) {
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(5, opnd+1, 1);
@@ -5678,11 +6200,18 @@ TEBCresume(
CACHE_STACK_INFO();
TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp));
} else {
+ if (*pc == INST_DICT_EXISTS) {
+ dictNotExists:
+ objResultPtr = TCONST(0);
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(5, opnd+1, 1);
+ }
TRACE_WITH_OBJ((
"%u => ERROR reading leaf dictionary key \"%s\": ",
opnd, O2S(dictPtr)), Tcl_GetObjResult(interp));
}
goto gotError;
+ }
case INST_DICT_SET:
case INST_DICT_UNSET:
diff --git a/generic/tclInt.h b/generic/tclInt.h
index ea712b8..1d04c82 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2797,7 +2797,9 @@ 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_NRPostProc TclNRTailcallEval;
MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
@@ -3489,6 +3491,15 @@ MODULE_SCOPE int Tcl_WhileObjCmd(ClientData clientData,
MODULE_SCOPE int TclCompileAppendCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileArrayExistsCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileArraySetCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileArrayUnsetCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileBreakCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -3501,10 +3512,13 @@ MODULE_SCOPE int TclCompileContinueCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileDictAppendCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclCompileDictForCmd(Tcl_Interp *interp,
+MODULE_SCOPE int TclCompileDictCreateCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclCompileDictMapCmd(Tcl_Interp *interp,
+MODULE_SCOPE int TclCompileDictExistsCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileDictForCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileDictGetCmd(Tcl_Interp *interp,
@@ -3516,6 +3530,12 @@ MODULE_SCOPE int TclCompileDictIncrCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileDictLappendCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileDictMapCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileDictMergeCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileDictSetCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -3543,15 +3563,36 @@ MODULE_SCOPE int TclCompileForCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileForeachCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileFormatCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileGlobalCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
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 TclCompileInfoObjectClassCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileInfoObjectIsACmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileInfoObjectNamespaceCmd(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,15 +3623,36 @@ 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 TclCompileNamespaceQualifiersCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileNamespaceTailCmd(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);
+MODULE_SCOPE int TclCompileRegsubCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileReturnCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -3603,21 +3665,36 @@ MODULE_SCOPE int TclCompileStringCmpCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileStringEqualCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringLastCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileStringLenCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringMapCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileStringMatchCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringRangeCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileSubstCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileSwitchCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileTailcallCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileThrowCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -3636,6 +3713,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..02d517f 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, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0},
+ {"tail", NamespaceTailCmd, TclCompileNamespaceTailCmd, 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/generic/tclOOInfo.c b/generic/tclOOInfo.c
index 1a94e69..e09ee4e 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -43,47 +43,45 @@ static Tcl_ObjCmdProc InfoClassSubsCmd;
static Tcl_ObjCmdProc InfoClassSupersCmd;
static Tcl_ObjCmdProc InfoClassVariablesCmd;
-struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; };
-
/*
* List of commands that are used to implement the [info object] subcommands.
*/
-static const struct NameProcMap infoObjectCmds[] = {
- {"::oo::InfoObject::call", InfoObjectCallCmd},
- {"::oo::InfoObject::class", InfoObjectClassCmd},
- {"::oo::InfoObject::definition", InfoObjectDefnCmd},
- {"::oo::InfoObject::filters", InfoObjectFiltersCmd},
- {"::oo::InfoObject::forward", InfoObjectForwardCmd},
- {"::oo::InfoObject::isa", InfoObjectIsACmd},
- {"::oo::InfoObject::methods", InfoObjectMethodsCmd},
- {"::oo::InfoObject::methodtype", InfoObjectMethodTypeCmd},
- {"::oo::InfoObject::mixins", InfoObjectMixinsCmd},
- {"::oo::InfoObject::namespace", InfoObjectNsCmd},
- {"::oo::InfoObject::variables", InfoObjectVariablesCmd},
- {"::oo::InfoObject::vars", InfoObjectVarsCmd},
- {NULL, NULL}
+static const EnsembleImplMap infoObjectCmds[] = {
+ {"call", InfoObjectCallCmd, NULL, NULL, NULL, 0},
+ {"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0},
+ {"definition", InfoObjectDefnCmd, NULL, NULL, NULL, 0},
+ {"filters", InfoObjectFiltersCmd, NULL, NULL, NULL, 0},
+ {"forward", InfoObjectForwardCmd, NULL, NULL, NULL, 0},
+ {"isa", InfoObjectIsACmd, TclCompileInfoObjectIsACmd, NULL, NULL, 0},
+ {"methods", InfoObjectMethodsCmd, NULL, NULL, NULL, 0},
+ {"methodtype", InfoObjectMethodTypeCmd, NULL, NULL, NULL, 0},
+ {"mixins", InfoObjectMixinsCmd, NULL, NULL, NULL, 0},
+ {"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0},
+ {"variables", InfoObjectVariablesCmd, NULL, NULL, NULL, 0},
+ {"vars", InfoObjectVarsCmd, NULL, NULL, NULL, 0},
+ {NULL, NULL, NULL, NULL, NULL, 0}
};
/*
* List of commands that are used to implement the [info class] subcommands.
*/
-static const struct NameProcMap infoClassCmds[] = {
- {"::oo::InfoClass::call", InfoClassCallCmd},
- {"::oo::InfoClass::constructor", InfoClassConstrCmd},
- {"::oo::InfoClass::definition", InfoClassDefnCmd},
- {"::oo::InfoClass::destructor", InfoClassDestrCmd},
- {"::oo::InfoClass::filters", InfoClassFiltersCmd},
- {"::oo::InfoClass::forward", InfoClassForwardCmd},
- {"::oo::InfoClass::instances", InfoClassInstancesCmd},
- {"::oo::InfoClass::methods", InfoClassMethodsCmd},
- {"::oo::InfoClass::methodtype", InfoClassMethodTypeCmd},
- {"::oo::InfoClass::mixins", InfoClassMixinsCmd},
- {"::oo::InfoClass::subclasses", InfoClassSubsCmd},
- {"::oo::InfoClass::superclasses", InfoClassSupersCmd},
- {"::oo::InfoClass::variables", InfoClassVariablesCmd},
- {NULL, NULL}
+static const EnsembleImplMap infoClassCmds[] = {
+ {"call", InfoClassCallCmd, NULL, NULL, NULL, 0},
+ {"constructor", InfoClassConstrCmd, NULL, NULL, NULL, 0},
+ {"definition", InfoClassDefnCmd, NULL, NULL, NULL, 0},
+ {"destructor", InfoClassDestrCmd, NULL, NULL, NULL, 0},
+ {"filters", InfoClassFiltersCmd, NULL, NULL, NULL, 0},
+ {"forward", InfoClassForwardCmd, NULL, NULL, NULL, 0},
+ {"instances", InfoClassInstancesCmd, NULL, NULL, NULL, 0},
+ {"methods", InfoClassMethodsCmd, NULL, NULL, NULL, 0},
+ {"methodtype", InfoClassMethodTypeCmd, NULL, NULL, NULL, 0},
+ {"mixins", InfoClassMixinsCmd, NULL, NULL, NULL, 0},
+ {"subclasses", InfoClassSubsCmd, NULL, NULL, NULL, 0},
+ {"superclasses", InfoClassSupersCmd, NULL, NULL, NULL, 0},
+ {"variables", InfoClassVariablesCmd, NULL, NULL, NULL, 0},
+ {NULL, NULL, NULL, NULL, NULL, 0}
};
/*
@@ -101,33 +99,14 @@ void
TclOOInitInfo(
Tcl_Interp *interp)
{
- Tcl_Namespace *nsPtr;
Tcl_Command infoCmd;
- int i;
-
- /*
- * Build the ensemble used to implement [info object].
- */
-
- nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoObject", NULL, NULL);
- Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX);
- Tcl_Export(interp, nsPtr, "[a-z]*", 1);
- for (i=0 ; infoObjectCmds[i].name!=NULL ; i++) {
- Tcl_CreateObjCommand(interp, infoObjectCmds[i].name,
- infoObjectCmds[i].proc, NULL, NULL);
- }
/*
- * Build the ensemble used to implement [info class].
+ * Build the ensembles used to implement [info object] and [info class].
*/
- nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoClass", NULL, NULL);
- Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX);
- Tcl_Export(interp, nsPtr, "[a-z]*", 1);
- for (i=0 ; infoClassCmds[i].name!=NULL ; i++) {
- Tcl_CreateObjCommand(interp, infoClassCmds[i].name,
- infoClassCmds[i].proc, NULL, NULL);
- }
+ TclMakeEnsemble(interp, "::oo::InfoObject", infoObjectCmds);
+ TclMakeEnsemble(interp, "::oo::InfoClass", infoClassCmds);
/*
* Install into the master [info] ensemble.
diff --git a/generic/tclVar.c b/generic/tclVar.c
index e31e9cf..1c01e41 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -4224,15 +4224,15 @@ TclInitArrayCmd(
static const EnsembleImplMap arrayImplMap[] = {
{"anymore", ArrayAnyMoreCmd, NULL, NULL, NULL, 0},
{"donesearch", ArrayDoneSearchCmd, NULL, NULL, NULL, 0},
- {"exists", ArrayExistsCmd, NULL, NULL, NULL, 0},
+ {"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0},
{"get", ArrayGetCmd, NULL, NULL, NULL, 0},
{"names", ArrayNamesCmd, NULL, NULL, NULL, 0},
{"nextelement", ArrayNextElementCmd, NULL, NULL, NULL, 0},
- {"set", ArraySetCmd, NULL, NULL, NULL, 0},
+ {"set", ArraySetCmd, TclCompileArraySetCmd, NULL, NULL, 0},
{"size", ArraySizeCmd, NULL, NULL, NULL, 0},
{"startsearch", ArrayStartSearchCmd, NULL, NULL, NULL, 0},
{"statistics", ArrayStatsCmd, NULL, NULL, NULL, 0},
- {"unset", ArrayUnsetCmd, NULL, NULL, NULL, 0},
+ {"unset", ArrayUnsetCmd, TclCompileArrayUnsetCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
diff --git a/tests/dict.test b/tests/dict.test
index 72f239e..22d652b 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -78,6 +78,24 @@ test dict-2.7 {dict create command - #-quoting in string rep} {
test dict-2.8 {dict create command - #-quoting in string rep} -body {
dict create #a x #b x
} -match glob -result {{#?} x #? x}
+test dict-2.9 {dict create command: compilation} {
+ apply {{} {dict create [format a] b}}
+} {a b}
+test dict-2.10 {dict create command: compilation} {
+ apply {{} {dict create [format a] b c d}}
+} {a b c d}
+test dict-2.11 {dict create command: compilation} {
+ apply {{} {dict create [format a] b c d a x}}
+} {a x c d}
+test dict-2.12 {dict create command: non-compilation} {
+ dict create [format a] b
+} {a b}
+test dict-2.13 {dict create command: non-compilation} {
+ dict create [format a] b c d
+} {a b c d}
+test dict-2.14 {dict create command: non-compilation} {
+ dict create [format a] b c d a x
+} {a x c d}
test dict-3.1 {dict get command} {dict get {a b} a} b
test dict-3.2 {dict get command} {dict get {a b c d} a} b
@@ -1160,6 +1178,36 @@ test dict-20.9 {dict merge command} {
test dict-20.10 {dict merge command} {
dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -}
} {a - c d e f 1 - 3 4}
+test dict-20.11 {dict merge command} {
+ apply {{} {dict merge}}
+} {}
+test dict-20.12 {dict merge command} {
+ apply {{} {dict merge {a b c d e f}}}
+} {a b c d e f}
+test dict-20.13 {dict merge command} -body {
+ apply {{} {dict merge {a b c d e}}}
+} -result {missing value to go with key} -returnCodes error
+test dict-20.14 {dict merge command} {
+ apply {{} {dict merge {a b c d} {e f g h}}}
+} {a b c d e f g h}
+test dict-20.15 {dict merge command} -body {
+ apply {{} {dict merge {a b c d e} {e f g h}}}
+} -result {missing value to go with key} -returnCodes error
+test dict-20.16 {dict merge command} -body {
+ apply {{} {dict merge {a b c d} {e f g h i}}}
+} -result {missing value to go with key} -returnCodes error
+test dict-20.17 {dict merge command} {
+ apply {{} {dict merge {a b c d e f} {e x g h}}}
+} {a b c d e x g h}
+test dict-20.18 {dict merge command} {
+ apply {{} {dict merge {a b c d} {a x c y}}}
+} {a x c y}
+test dict-20.19 {dict merge command} {
+ apply {{} {dict merge {a b c d} {c y a x}}}
+} {a x c y}
+test dict-20.20 {dict merge command} {
+ apply {{} {dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -}}}
+} {a - c d e f 1 - 3 4}
test dict-21.1 {dict update command} -returnCodes 1 -body {
dict update
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 2024-11-23 21:19:33 (GMT)