summaryrefslogtreecommitdiffstats
path: root/generic/tclCompCmds.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclCompCmds.c')
-rw-r--r--generic/tclCompCmds.c6508
1 files changed, 1802 insertions, 4706 deletions
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 106c293..6a22a30 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -7,7 +7,7 @@
* Copyright (c) 1997-1998 Sun Microsystems, Inc.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
* Copyright (c) 2002 ActiveState Corporation.
- * Copyright (c) 2004-2006 by Donal K. Fellows.
+ * Copyright (c) 2004-2013 by Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -15,123 +15,7 @@
#include "tclInt.h"
#include "tclCompile.h"
-
-/*
- * Macro that encapsulates an efficiency trick that avoids a function call for
- * the simplest of compiles. The ANSI C "prototype" for this macro is:
- *
- * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr,
- * Tcl_Interp *interp, int word);
- */
-
-#define CompileWord(envPtr, tokenPtr, interp, word) \
- if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \
- TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \
- (tokenPtr)[1].size), (envPtr)); \
- } else { \
- envPtr->line = mapPtr->loc[eclIndex].line[word]; \
- envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \
- TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
- (envPtr)); \
- }
-
-/*
- * TIP #280: Remember the per-word line information of the current command. An
- * index is used instead of a pointer as recursive compilation may reallocate,
- * i.e. move, the array. This is also the reason to save the nuloc now, it may
- * change during the course of the function.
- *
- * Macro to encapsulate the variable definition and setup.
- */
-
-#define DefineLineInformation \
- ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
- int eclIndex = mapPtr->nuloc - 1
-
-#define SetLineInformation(word) \
- envPtr->line = mapPtr->loc [eclIndex].line [(word)]; \
- envPtr->clNext = mapPtr->loc [eclIndex].next [(word)]
-
-/*
- * Convenience macro for use when compiling bodies of commands. The ANSI C
- * "prototype" for this macro is:
- *
- * static void CompileBody(CompileEnv *envPtr, Tcl_Token *tokenPtr,
- * Tcl_Interp *interp);
- */
-
-#define CompileBody(envPtr, tokenPtr, interp) \
- TclCompileCmdWord((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
- (envPtr))
-
-/*
- * Convenience macro for use when compiling tokens to be pushed. The ANSI C
- * "prototype" for this macro is:
- *
- * static void CompileTokens(CompileEnv *envPtr, Tcl_Token *tokenPtr,
- * Tcl_Interp *interp);
- */
-
-#define CompileTokens(envPtr, tokenPtr, interp) \
- TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
- (envPtr));
-/*
- * Convenience macro for use when pushing literals. The ANSI C "prototype" for
- * this macro is:
- *
- * static void PushLiteral(CompileEnv *envPtr,
- * const char *string, int length);
- */
-
-#define PushLiteral(envPtr, string, length) \
- TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr))
-
-/*
- * Macro to advance to the next token; it is more mnemonic than the address
- * arithmetic that it replaces. The ANSI C "prototype" for this macro is:
- *
- * static Tcl_Token * TokenAfter(Tcl_Token *tokenPtr);
- */
-
-#define TokenAfter(tokenPtr) \
- ((tokenPtr) + ((tokenPtr)->numComponents + 1))
-
-/*
- * Macro to get the offset to the next instruction to be issued. The ANSI C
- * "prototype" for this macro is:
- *
- * static int CurrentOffset(CompileEnv *envPtr);
- */
-
-#define CurrentOffset(envPtr) \
- ((envPtr)->codeNext - (envPtr)->codeStart)
-
-/*
- * Note: the exceptDepth is a bit of a misnomer: TEBC only needs the
- * maximal depth of nested CATCH ranges in order to alloc runtime
- * memory. These macros should compute precisely that? OTOH, the nesting depth
- * of LOOP ranges is an interesting datum for debugging purposes, and that is
- * what we compute now.
- *
- * static int DeclareExceptionRange(CompileEnv *envPtr, int type);
- * static int ExceptionRangeStarts(CompileEnv *envPtr, int index);
- * static void ExceptionRangeEnds(CompileEnv *envPtr, int index);
- * static void ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL);
- */
-
-#define DeclareExceptionRange(envPtr, type) \
- (TclCreateExceptRange((type), (envPtr)))
-#define ExceptionRangeStarts(envPtr, index) \
- (((envPtr)->exceptDepth++), \
- ((envPtr)->maxExceptDepth = \
- TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \
- ((envPtr)->exceptArrayPtr[(index)].codeOffset = CurrentOffset(envPtr)))
-#define ExceptionRangeEnds(envPtr, index) \
- (((envPtr)->exceptDepth--), \
- ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \
- CurrentOffset(envPtr) - (envPtr)->exceptArrayPtr[(index)].codeOffset))
-#define ExceptionRangeTarget(envPtr, index, targetType) \
- ((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr))
+#include <assert.h>
/*
* Prototypes for procedures defined later in this file:
@@ -142,76 +26,56 @@ static void FreeDictUpdateInfo(ClientData clientData);
static void PrintDictUpdateInfo(ClientData clientData,
Tcl_Obj *appendObj, ByteCode *codePtr,
unsigned int pcOffset);
+static void DisassembleDictUpdateInfo(ClientData clientData,
+ Tcl_Obj *dictObj, ByteCode *codePtr,
+ unsigned int pcOffset);
static ClientData DupForeachInfo(ClientData clientData);
static void FreeForeachInfo(ClientData clientData);
static void PrintForeachInfo(ClientData clientData,
Tcl_Obj *appendObj, ByteCode *codePtr,
unsigned int pcOffset);
-static ClientData DupJumptableInfo(ClientData clientData);
-static void FreeJumptableInfo(ClientData clientData);
-static void PrintJumptableInfo(ClientData clientData,
+static void DisassembleForeachInfo(ClientData clientData,
+ Tcl_Obj *dictObj, ByteCode *codePtr,
+ unsigned int pcOffset);
+static void PrintNewForeachInfo(ClientData clientData,
Tcl_Obj *appendObj, ByteCode *codePtr,
unsigned int pcOffset);
-static int LocalScalarFromToken(Tcl_Token *tokenPtr,
- CompileEnv *envPtr);
-static int LocalScalar(const char *bytes, int numBytes,
- CompileEnv *envPtr);
-static int PushVarName(Tcl_Interp *interp,
- Tcl_Token *varTokenPtr, CompileEnv *envPtr,
- int flags, int *localIndexPtr,
- int *simpleVarNamePtr, int *isScalarPtr,
- int line, int* clNext);
-static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp,
- Tcl_Parse *parsePtr, const char *identity,
- int instruction, CompileEnv *envPtr);
-static int CompileComparisonOpCmd(Tcl_Interp *interp,
- Tcl_Parse *parsePtr, int instruction,
- CompileEnv *envPtr);
-static int CompileStrictlyBinaryOpCmd(Tcl_Interp *interp,
- Tcl_Parse *parsePtr, int instruction,
- CompileEnv *envPtr);
-static int CompileUnaryOpCmd(Tcl_Interp *interp,
- Tcl_Parse *parsePtr, int instruction,
- CompileEnv *envPtr);
-static void CompileReturnInternal(CompileEnv *envPtr,
- unsigned char op, int code, int level,
- Tcl_Obj *returnOpts);
-
-#define PushVarNameWord(i,v,e,f,l,s,sc,word) \
- PushVarName (i,v,e,f,l,s,sc, \
- mapPtr->loc [eclIndex].line [(word)], \
- mapPtr->loc [eclIndex].next [(word)])
-
-/*
- * Flags bits used by PushVarName.
- */
-
-#define TCL_CREATE_VAR 1 /* Create a compiled local if none is found */
-#define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */
+static void DisassembleNewForeachInfo(ClientData clientData,
+ Tcl_Obj *dictObj, ByteCode *codePtr,
+ unsigned int pcOffset);
+static int CompileEachloopCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ CompileEnv *envPtr, int collect);
+static int CompileDictEachCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr, int collect);
/*
* The structures below define the AuxData types defined in this file.
*/
-AuxDataType tclForeachInfoType = {
+const AuxDataType tclForeachInfoType = {
"ForeachInfo", /* name */
DupForeachInfo, /* dupProc */
FreeForeachInfo, /* freeProc */
- PrintForeachInfo /* printProc */
+ PrintForeachInfo, /* printProc */
+ DisassembleForeachInfo /* disassembleProc */
};
-AuxDataType tclJumptableInfoType = {
- "JumptableInfo", /* name */
- DupJumptableInfo, /* dupProc */
- FreeJumptableInfo, /* freeProc */
- PrintJumptableInfo /* printProc */
+const AuxDataType tclNewForeachInfoType = {
+ "NewForeachInfo", /* name */
+ DupForeachInfo, /* dupProc */
+ FreeForeachInfo, /* freeProc */
+ PrintNewForeachInfo, /* printProc */
+ DisassembleNewForeachInfo /* disassembleProc */
};
-AuxDataType tclDictUpdateInfoType = {
+const AuxDataType tclDictUpdateInfoType = {
"DictUpdateInfo", /* name */
DupDictUpdateInfo, /* dupProc */
FreeDictUpdateInfo, /* freeProc */
- PrintDictUpdateInfo /* printProc */
+ PrintDictUpdateInfo, /* printProc */
+ DisassembleDictUpdateInfo /* disassembleProc */
};
/*
@@ -222,8 +86,8 @@ AuxDataType tclDictUpdateInfoType = {
* Procedure called to compile the "append" command.
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * 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 "append" command at
@@ -242,9 +106,10 @@ TclCompileAppendCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *valueTokenPtr;
- int simpleVarName, isScalar, localIndex, numWords;
+ int isScalar, localIndex, numWords, i;
DefineLineInformation; /* TIP #280 */
+ /* TODO: Consider support for compiling expanded args. */
numWords = parsePtr->numWords;
if (numWords == 1) {
return TCL_ERROR;
@@ -256,10 +121,11 @@ TclCompileAppendCmd(
return TclCompileSetCmd(interp, parsePtr, cmdPtr, envPtr);
} else if (numWords > 3) {
/*
- * APPEND instructions currently only handle one value.
+ * APPEND instructions currently only handle one value, but we can
+ * handle some multi-value cases by stringing them together.
*/
- return TCL_ERROR;
+ goto appendMultiple;
}
/*
@@ -272,8 +138,8 @@ TclCompileAppendCmd(
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
- &localIndex, &simpleVarName, &isScalar, 1);
+ PushVarNameWord(interp, varTokenPtr, envPtr, 0,
+ &localIndex, &isScalar, 1);
/*
* We are doing an assignment, otherwise TclCompileSetCmd was called, so
@@ -281,37 +147,313 @@ TclCompileAppendCmd(
* each argument.
*/
- if (numWords > 2) {
valueTokenPtr = TokenAfter(varTokenPtr);
CompileWord(envPtr, valueTokenPtr, interp, 2);
- }
/*
* Emit instructions to set/get the variable.
*/
- if (simpleVarName) {
if (isScalar) {
if (localIndex < 0) {
TclEmitOpcode(INST_APPEND_STK, envPtr);
- } else if (localIndex <= 255) {
- TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr);
} else {
- TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr);
+ Emit14Inst(INST_APPEND_SCALAR, localIndex, envPtr);
}
} else {
if (localIndex < 0) {
TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr);
- } else if (localIndex <= 255) {
- TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr);
} else {
- TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr);
+ Emit14Inst(INST_APPEND_ARRAY, localIndex, envPtr);
}
}
+
+ return TCL_OK;
+
+ appendMultiple:
+ /*
+ * Can only handle the case where we are appending to a local scalar when
+ * there are multiple values to append. Fortunately, this is common.
+ */
+
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ localIndex = LocalScalarFromToken(varTokenPtr, envPtr);
+ if (localIndex < 0) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Definitely appending to a local scalar; generate the words and append
+ * them.
+ */
+
+ valueTokenPtr = TokenAfter(varTokenPtr);
+ for (i = 2 ; i < numWords ; i++) {
+ CompileWord(envPtr, valueTokenPtr, interp, i);
+ valueTokenPtr = TokenAfter(valueTokenPtr);
+ }
+ TclEmitInstInt4( INST_REVERSE, numWords-2, envPtr);
+ for (i = 2 ; i < numWords ;) {
+ Emit14Inst( INST_APPEND_SCALAR, localIndex, envPtr);
+ if (++i < numWords) {
+ TclEmitOpcode(INST_POP, envPtr);
+ }
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 isScalar, localIndex;
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT,
+ &localIndex, &isScalar, 1);
+ if (!isScalar) {
+ return TCL_ERROR;
+ }
+
+ if (localIndex >= 0) {
+ TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
} else {
- TclEmitOpcode(INST_APPEND_STK, envPtr);
+ 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 *varTokenPtr, *dataTokenPtr;
+ int isScalar, localIndex, code = TCL_OK;
+ int isDataLiteral, isDataValid, isDataEven, len;
+ int keyVar, valVar, infoIndex;
+ int fwd, offsetBack, offsetFwd;
+ Tcl_Obj *literalObj;
+ ForeachInfo *infoPtr;
+ if (parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ dataTokenPtr = TokenAfter(varTokenPtr);
+ literalObj = Tcl_NewObj();
+ isDataLiteral = TclWordKnownAtCompileTime(dataTokenPtr, literalObj);
+ isDataValid = (isDataLiteral
+ && Tcl_ListObjLength(NULL, literalObj, &len) == TCL_OK);
+ isDataEven = (isDataValid && (len & 1) == 0);
+
+ /*
+ * Special case: literal odd-length argument is always an error.
+ */
+
+ if (isDataValid && !isDataEven) {
+ PushStringLiteral(envPtr, "list must have an even number of elements");
+ PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}");
+ TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr);
+ TclEmitInt4( 0, envPtr);
+ goto done;
+ }
+
+ /*
+ * Except for the special "ensure array" case below, when we're not in
+ * a proc, we cannot do a better compile than generic.
+ */
+
+ if ((varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) ||
+ (envPtr->procPtr == NULL && !(isDataEven && len == 0))) {
+ code = TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ goto done;
+ }
+
+ PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT,
+ &localIndex, &isScalar, 1);
+ if (!isScalar) {
+ code = TCL_ERROR;
+ goto done;
+ }
+
+ /*
+ * Special case: literal empty value argument is just an "ensure array"
+ * operation.
+ */
+
+ if (isDataEven && len == 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);
+ TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr);
+ TclEmitInstInt1(INST_JUMP1, 3, envPtr);
+ /* Each branch decrements stack depth, but we only take one. */
+ TclAdjustStackDepth(1, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+ PushStringLiteral(envPtr, "");
+ goto done;
+ }
+
+ if (localIndex < 0) {
+ /*
+ * a non-local variable: upvar from a local one! This consumes the
+ * variable name that was left at stacktop.
+ */
+
+ localIndex = TclFindCompiledLocal(varTokenPtr->start,
+ varTokenPtr->size, 1, envPtr);
+ PushStringLiteral(envPtr, "0");
+ TclEmitInstInt4(INST_REVERSE, 2, envPtr);
+ TclEmitInstInt4(INST_UPVAR, localIndex, envPtr);
+ TclEmitOpcode(INST_POP, envPtr);
+ }
+
+ /*
+ * Prepare for the internal foreach.
+ */
+
+ keyVar = AnonymousLocal(envPtr);
+ valVar = AnonymousLocal(envPtr);
+
+ infoPtr = ckalloc(sizeof(ForeachInfo));
+ infoPtr->numLists = 1;
+ infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) + 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, dataTokenPtr, interp, 2);
+ if (!isDataLiteral || !isDataValid) {
+ /*
+ * Only need this safety check if we're handling a non-literal or list
+ * containing an invalid literal; with valid list literals, we've
+ * already checked (worth it because literals are a very common
+ * use-case with [array set]).
+ */
+
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_LIST_LENGTH, envPtr);
+ PushStringLiteral(envPtr, "1");
+ TclEmitOpcode( INST_BITAND, envPtr);
+ offsetFwd = CurrentOffset(envPtr);
+ TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
+ PushStringLiteral(envPtr, "list must have an even number of elements");
+ PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}");
+ TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr);
+ TclEmitInt4( 0, envPtr);
+ TclAdjustStackDepth(-1, envPtr);
+ fwd = CurrentOffset(envPtr) - offsetFwd;
+ TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
+ }
+
+ TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
+ TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr);
+ TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr);
+ TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr);
+ offsetBack = CurrentOffset(envPtr);
+ Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr);
+ Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr);
+ Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ infoPtr->loopCtTemp = offsetBack - CurrentOffset(envPtr); /*misuse */
+ TclEmitOpcode( INST_FOREACH_STEP, envPtr);
+ TclEmitOpcode( INST_FOREACH_END, envPtr);
+ TclAdjustStackDepth(-3, envPtr);
+ PushStringLiteral(envPtr, "");
+
+ done:
+ Tcl_DecrRefCount(literalObj);
+ return code;
+}
+
+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 isScalar, localIndex;
+
+ if (parsePtr->numWords != 2) {
+ return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ }
+
+ PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT,
+ &localIndex, &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);
+ TclEmitInstInt1(INST_UNSET_STK, 1, envPtr);
+ TclEmitInstInt1(INST_JUMP1, 3, envPtr);
+ /* Each branch decrements stack depth, but we only take one. */
+ TclAdjustStackDepth(1, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+ PushStringLiteral(envPtr, "");
return TCL_OK;
}
@@ -323,8 +465,8 @@ TclCompileAppendCmd(
* Procedure called to compile the "break" command.
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * 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 "break" command at
@@ -342,15 +484,34 @@ TclCompileBreakCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
+ ExceptionRange *rangePtr;
+ ExceptionAux *auxPtr;
+
if (parsePtr->numWords != 1) {
return TCL_ERROR;
}
/*
- * Emit a break instruction.
+ * Find the innermost exception range that contains this command.
*/
- TclEmitOpcode(INST_BREAK, envPtr);
+ rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxPtr);
+ if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
+ /*
+ * Found the target! No need for a nasty INST_BREAK here.
+ */
+
+ TclCleanupStackForBreakContinue(envPtr, auxPtr);
+ TclAddLoopBreakFixup(envPtr, auxPtr);
+ } else {
+ /*
+ * Emit a real break.
+ */
+
+ TclEmitOpcode(INST_BREAK, envPtr);
+ }
+ TclAdjustStackDepth(1, envPtr);
+
return TCL_OK;
}
@@ -383,11 +544,10 @@ TclCompileCatchCmd(
{
JumpFixup jumpFixup;
Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr;
- int resultIndex, optsIndex, range;
- int initStackDepth = envPtr->currStackDepth;
- int savedStackDepth;
+ int resultIndex, optsIndex, range, dropScript = 0;
DefineLineInformation; /* TIP #280 */
-
+ int depth = TclGetStackDepth(envPtr);
+
/*
* If syntax does not match what we expect for [catch], do not compile.
* Let runtime checks determine if syntax has changed.
@@ -398,6 +558,15 @@ TclCompileCatchCmd(
}
/*
+ * If variables were specified and the catch command is at global level
+ * (not in a procedure), don't compile it inline: the payoff is too small.
+ */
+
+ if ((parsePtr->numWords >= 3) && !EnvHasLVT(envPtr)) {
+ return TCL_ERROR;
+ }
+
+ /*
* Make sure the variable names, if any, have no substitutions and just
* refer to local scalars.
*/
@@ -406,11 +575,13 @@ TclCompileCatchCmd(
cmdTokenPtr = TokenAfter(parsePtr->tokenPtr);
if (parsePtr->numWords >= 3) {
resultNameTokenPtr = TokenAfter(cmdTokenPtr);
+ /* DGP */
resultIndex = LocalScalarFromToken(resultNameTokenPtr, envPtr);
if (resultIndex < 0) {
return TCL_ERROR;
}
+ /* DKF */
if (parsePtr->numWords == 4) {
optsNameTokenPtr = TokenAfter(resultNameTokenPtr);
optsIndex = LocalScalarFromToken(optsNameTokenPtr, envPtr);
@@ -421,148 +592,199 @@ TclCompileCatchCmd(
}
/*
- * We will compile the catch command. Declare the exception range
- * that it uses.
- */
-
- range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
-
- /*
+ * We will compile the catch command. Declare the exception range that it
+ * uses.
+ *
* If the body is a simple word, compile a BEGIN_CATCH instruction,
* followed by the instructions to eval the body.
* Otherwise, compile instructions to substitute the body text before
- * starting the catch, then BEGIN_CATCH, and then EVAL_STK to
- * evaluate the substituted body.
- * Care has to be taken to make sure that substitution happens outside
- * the catch range so that errors in the substitution are not caught.
+ * starting the catch, then BEGIN_CATCH, and then EVAL_STK to evaluate the
+ * substituted body.
+ * Care has to be taken to make sure that substitution happens outside the
+ * catch range so that errors in the substitution are not caught.
* [Bug 219184]
* The reason for duplicating the script is that EVAL_STK would otherwise
* begin by undeflowing the stack below the mark set by BEGIN_CATCH4.
*/
- SetLineInformation(1);
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- savedStackDepth = envPtr->currStackDepth;
- TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);
+ TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
ExceptionRangeStarts(envPtr, range);
- CompileBody(envPtr, cmdTokenPtr, interp);
+ BODY(cmdTokenPtr, 1);
} else {
+ SetLineInformation(1);
CompileTokens(envPtr, cmdTokenPtr, interp);
- savedStackDepth = envPtr->currStackDepth;
- TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);
+ TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
ExceptionRangeStarts(envPtr, range);
- TclEmitOpcode(INST_DUP, envPtr);
- TclEmitOpcode(INST_EVAL_STK, envPtr);
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitInvoke(envPtr, INST_EVAL_STK);
+ /* drop the script */
+ dropScript = 1;
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
}
- /* Stack at this point:
- * nonsimple: script <mark> result
- * simple: <mark> result
- */
+ ExceptionRangeEnds(envPtr, range);
+
/*
- * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch
- * result, and jump around the "error case" code.
+ * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result,
+ * and jump around the "error case" code.
*/
- PushLiteral(envPtr, "0", 1);
+ TclCheckStackDepth(depth+1, envPtr);
+ PushStringLiteral(envPtr, "0");
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
- /* Stack at this point: ?script? <mark> result TCL_OK */
- /*
- * Emit the "error case" epilogue. Push the interpreter result
- * and the return code.
+ /*
+ * Emit the "error case" epilogue. Push the interpreter result and the
+ * return code.
*/
- envPtr->currStackDepth = savedStackDepth;
ExceptionRangeTarget(envPtr, range, catchOffset);
- /* Stack at this point: ?script? */
- TclEmitOpcode(INST_PUSH_RESULT, envPtr);
- TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
+ TclSetStackDepth(depth + dropScript, envPtr);
+
+ if (dropScript) {
+ TclEmitOpcode( INST_POP, envPtr);
+ }
- /*
- * Update the target of the jump after the "no errors" code.
- */
- /* Stack at this point: ?script? result returnCode */
+ /* Stack at this point is empty */
+ TclEmitOpcode( INST_PUSH_RESULT, envPtr);
+ TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr);
+
+ /* Stack at this point on both branches: result returnCode */
+
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
Tcl_Panic("TclCompileCatchCmd: bad jump distance %d",
- (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
+ (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset));
}
- /* Push the return options if the caller wants them */
+ /*
+ * Push the return options if the caller wants them. This needs to happen
+ * before INST_END_CATCH
+ */
if (optsIndex != -1) {
- TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr);
+ TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
}
/*
* End the catch
*/
- ExceptionRangeEnds(envPtr, range);
- TclEmitOpcode(INST_END_CATCH, envPtr);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
/*
- * At this point, the top of the stack is inconveniently ordered:
- * ?script? result returnCode ?returnOptions?
- * Reverse the stack to bring the result to the top.
+ * Save the result and return options if the caller wants them. This needs
+ * to happen after INST_END_CATCH (compile-3.6/7).
*/
if (optsIndex != -1) {
- TclEmitInstInt4(INST_REVERSE, 3, envPtr);
- } else {
- TclEmitInstInt4(INST_REVERSE, 2, envPtr);
+ Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
}
/*
- * Store the result if requested, and remove it from the stack
+ * At this point, the top of the stack is inconveniently ordered:
+ * result returnCode
+ * Reverse the stack to store the result.
*/
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
if (resultIndex != -1) {
- if (resultIndex <= 255) {
- TclEmitInstInt1(INST_STORE_SCALAR1, resultIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_STORE_SCALAR4, resultIndex, envPtr);
- }
+ Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr);
}
- TclEmitOpcode(INST_POP, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
- /*
- * Stack is now ?script? ?returnOptions? returnCode.
- * If the options dict has been requested, it is buried on the stack
- * under the return code. Reverse the stack to bring it to the top,
- * store it and remove it from the stack.
- */
+ TclCheckStackDepth(depth+1, envPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileConcatCmd --
+ *
+ * Procedure called to compile the "concat" 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 "concat" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
- if (optsIndex != -1) {
- TclEmitInstInt4(INST_REVERSE, 2, envPtr);
- if (optsIndex <= 255) {
- TclEmitInstInt1(INST_STORE_SCALAR1, optsIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_STORE_SCALAR4, optsIndex, envPtr);
- }
- TclEmitOpcode(INST_POP, envPtr);
+int
+TclCompileConcatCmd(
+ 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_Obj *objPtr, *listObj;
+ Tcl_Token *tokenPtr;
+ int i;
+
+ /* TODO: Consider compiling expansion case. */
+ if (parsePtr->numWords == 1) {
+ /*
+ * [concat] without arguments just pushes an empty object.
+ */
+
+ PushStringLiteral(envPtr, "");
+ return TCL_OK;
}
/*
- * Stack is now ?script? result. Get rid of the subst'ed script
- * if it's hanging arond.
+ * Test if all arguments are compile-time known. If they are, we can
+ * implement with a simple push.
*/
- if (cmdTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- TclEmitInstInt4(INST_REVERSE, 2, envPtr);
- TclEmitOpcode(INST_POP, envPtr);
+ listObj = Tcl_NewObj();
+ for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) {
+ tokenPtr = TokenAfter(tokenPtr);
+ objPtr = Tcl_NewObj();
+ if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
+ Tcl_DecrRefCount(objPtr);
+ Tcl_DecrRefCount(listObj);
+ listObj = NULL;
+ break;
+ }
+ (void) Tcl_ListObjAppendElement(NULL, listObj, objPtr);
+ }
+ if (listObj != NULL) {
+ Tcl_Obj **objs;
+ const char *bytes;
+ int len;
+
+ Tcl_ListObjGetElements(NULL, listObj, &len, &objs);
+ objPtr = Tcl_ConcatObj(len, objs);
+ Tcl_DecrRefCount(listObj);
+ bytes = Tcl_GetStringFromObj(objPtr, &len);
+ PushLiteral(envPtr, bytes, len);
+ Tcl_DecrRefCount(objPtr);
+ return TCL_OK;
}
/*
- * Result of all this, on either branch, should have been to leave
- * one operand -- the return code -- on the stack.
+ * General case: runtime concat.
*/
- if (envPtr->currStackDepth != initStackDepth + 1) {
- Tcl_Panic("in TclCompileCatchCmd, currStackDepth = %d should be %d",
- envPtr->currStackDepth, initStackDepth+1);
+ for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, i);
}
+
+ TclEmitInstInt4( INST_CONCAT_STK, i-1, envPtr);
+
return TCL_OK;
}
@@ -574,8 +796,8 @@ TclCompileCatchCmd(
* Procedure called to compile the "continue" command.
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * 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 "continue" command at
@@ -593,6 +815,9 @@ TclCompileContinueCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
+ ExceptionRange *rangePtr;
+ ExceptionAux *auxPtr;
+
/*
* There should be no argument after the "continue".
*/
@@ -602,10 +827,27 @@ TclCompileContinueCmd(
}
/*
- * Emit a continue instruction.
+ * See if we can find a valid continueOffset (i.e., not -1) in the
+ * innermost containing exception range.
*/
- TclEmitOpcode(INST_CONTINUE, envPtr);
+ rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, &auxPtr);
+ if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
+ /*
+ * Found the target! No need for a nasty INST_CONTINUE here.
+ */
+
+ TclCleanupStackForBreakContinue(envPtr, auxPtr);
+ TclAddLoopContinueFixup(envPtr, auxPtr);
+ } else {
+ /*
+ * Emit a real continue.
+ */
+
+ TclEmitOpcode(INST_CONTINUE, envPtr);
+ }
+ TclAdjustStackDepth(1, envPtr);
+
return TCL_OK;
}
@@ -617,32 +859,13 @@ TclCompileContinueCmd(
* Functions called to compile "dict" sucommands.
*
* Results:
- * All return TCL_OK for a successful compile, and TCL_ERROR to defer
- * evaluation to runtime.
+ * 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 "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 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!)
- *
*----------------------------------------------------------------------
*/
@@ -655,12 +878,13 @@ TclCompileDictSetCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
- Tcl_Token *tokenPtr, *varTokenPtr;
+ Tcl_Token *tokenPtr;
int i, dictVarIndex;
DefineLineInformation; /* TIP #280 */
+ Tcl_Token *varTokenPtr;
/*
- * There must be at least three arguments after the (sub-)command.
+ * There must be at least one argument after the command.
*/
if (parsePtr->numWords < 4) {
@@ -695,6 +919,7 @@ TclCompileDictSetCmd(
TclEmitInstInt4( INST_DICT_SET, parsePtr->numWords-3, envPtr);
TclEmitInt4( dictVarIndex, envPtr);
+ TclAdjustStackDepth(-1, envPtr);
return TCL_OK;
}
@@ -707,9 +932,9 @@ TclCompileDictIncrCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
+ DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *keyTokenPtr;
int dictVarIndex, incrAmount;
- DefineLineInformation; /* TIP #280 */
/*
* There must be at least two arguments after the command.
@@ -718,19 +943,7 @@ TclCompileDictIncrCmd(
if (parsePtr->numWords < 3 || parsePtr->numWords > 4) {
return TCL_ERROR;
}
-
- /*
- * The dictionary variable must be a local scalar that is knowable at
- * compile time; anything else exceeds the complexity of the opcode. So
- * discover what the index is.
- */
-
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr);
- if (dictVarIndex < 0) {
- return TCL_ERROR;
- }
-
keyTokenPtr = TokenAfter(varTokenPtr);
/*
@@ -738,19 +951,41 @@ TclCompileDictIncrCmd(
*/
if (parsePtr->numWords == 4) {
- Tcl_Token *incrTokenPtr = TokenAfter(keyTokenPtr);
- Tcl_Obj *intObj = Tcl_NewObj();
- int fail = (!TclWordKnownAtCompileTime(incrTokenPtr, intObj)
- || TCL_ERROR == TclGetIntFromObj(NULL, intObj, &incrAmount));
- Tcl_DecrRefCount(intObj);
- if (fail) {
- return TCL_ERROR;
+ const char *word;
+ int numBytes, code;
+ Tcl_Token *incrTokenPtr;
+ Tcl_Obj *intObj;
+
+ incrTokenPtr = TokenAfter(keyTokenPtr);
+ if (incrTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TclCompileBasic2Or3ArgCmd(interp, parsePtr,cmdPtr, envPtr);
+ }
+ word = incrTokenPtr[1].start;
+ numBytes = incrTokenPtr[1].size;
+
+ intObj = Tcl_NewStringObj(word, numBytes);
+ Tcl_IncrRefCount(intObj);
+ code = TclGetIntFromObj(NULL, intObj, &incrAmount);
+ TclDecrRefCount(intObj);
+ if (code != TCL_OK) {
+ return TclCompileBasic2Or3ArgCmd(interp, parsePtr,cmdPtr, envPtr);
}
} else {
incrAmount = 1;
}
/*
+ * The dictionary variable must be a local scalar that is knowable at
+ * compile time; anything else exceeds the complexity of the opcode. So
+ * discover what the index is.
+ */
+
+ dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr);
+ if (dictVarIndex < 0) {
+ return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ }
+
+ /*
* Emit the key and the code to actually do the increment.
*/
@@ -778,6 +1013,7 @@ TclCompileDictGetCmd(
* case is legal, but too special and magic for us to deal with here).
*/
+ /* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 3) {
return TCL_ERROR;
}
@@ -792,6 +1028,304 @@ TclCompileDictGetCmd(
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4(INST_DICT_GET, parsePtr->numWords-2, 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 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).
+ */
+
+ /* TODO: Consider support for compiling expanded args. */
+ if (parsePtr->numWords < 3) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ /*
+ * Now we do the code generation.
+ */
+
+ for (i=1 ; i<parsePtr->numWords ; i++) {
+ CompileWord(envPtr, tokenPtr, interp, i);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ TclEmitInstInt4(INST_DICT_EXISTS, parsePtr->numWords-2, envPtr);
+ TclAdjustStackDepth(-1, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileDictUnsetCmd(
+ 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;
+ DefineLineInformation; /* TIP #280 */
+ int i, dictVarIndex;
+
+ /*
+ * There must be at least one argument after the variable name for us to
+ * compile to bytecode.
+ */
+
+ /* TODO: Consider support for compiling expanded args. */
+ if (parsePtr->numWords < 3) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * The dictionary variable must be a local scalar that is knowable at
+ * compile time; anything else exceeds the complexity of the opcode. So
+ * discover what the index is.
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr);
+ if (dictVarIndex < 0) {
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ }
+
+ /*
+ * Remaining words (the key path) can be handled normally.
+ */
+
+ for (i=2 ; i<parsePtr->numWords ; i++) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, i);
+ }
+
+ /*
+ * Now emit the instruction to do the dict manipulation.
+ */
+
+ TclEmitInstInt4( INST_DICT_UNSET, parsePtr->numWords-2, 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 = AnonymousLocal(envPtr);
+ if (worker < 0) {
+ return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ }
+
+ PushStringLiteral(envPtr, "");
+ 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.
+ */
+
+ /* TODO: Consider support for compiling expanded args. (less likely) */
+ if (parsePtr->numWords < 2) {
+ PushStringLiteral(envPtr, "");
+ 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 = AnonymousLocal(envPtr);
+ if (workerIndex < 0) {
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ }
+ infoIndex = AnonymousLocal(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 = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ 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.
+ */
+
+ TclAdjustStackDepth(-1, envPtr);
+ 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;
}
@@ -804,32 +1338,71 @@ TclCompileDictForCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
- Proc *procPtr = envPtr->procPtr;
+ return CompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr,
+ TCL_EACH_KEEP_NONE);
+}
+
+int
+TclCompileDictMapCmd(
+ 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. */
+{
+ return CompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr,
+ TCL_EACH_COLLECT);
+}
+
+int
+CompileDictEachCmd(
+ 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. */
+ int collect) /* Flag == TCL_EACH_COLLECT to collect and
+ * construct a new dictionary with the loop
+ * body result. */
+{
+ DefineLineInformation; /* TIP #280 */
Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr;
- int keyVarIndex, valueVarIndex, loopRange, catchRange;
+ int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange;
int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset;
- int numVars, endTargetOffset, numBytes;
- const char *bytes;
- int savedStackDepth = envPtr->currStackDepth;
- /* Needed because jumps confuse the stack
- * space calculator. */
- Tcl_Obj *varNameObj, *varListObj = NULL;
- DefineLineInformation; /* TIP #280 */
+ int numVars, endTargetOffset;
+ int collectVar = -1; /* Index of temp var holding the result
+ * dict. */
+ const char **argv;
+ Tcl_DString buffer;
/*
- * There must be exactly three arguments after the command.
+ * There must be three arguments after the command.
*/
- if (parsePtr->numWords != 4 || procPtr == NULL) {
- return TCL_ERROR;
+ if (parsePtr->numWords != 4) {
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
varsTokenPtr = TokenAfter(parsePtr->tokenPtr);
dictTokenPtr = TokenAfter(varsTokenPtr);
bodyTokenPtr = TokenAfter(dictTokenPtr);
+ if (varsTokenPtr->type != TCL_TOKEN_SIMPLE_WORD ||
+ bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ }
- if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
+ /*
+ * Create temporary variable to capture return values from loop body when
+ * we're collecting results.
+ */
+
+ if (collect == TCL_EACH_COLLECT) {
+ collectVar = AnonymousLocal(envPtr);
+ if (collectVar < 0) {
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ }
}
/*
@@ -837,31 +1410,28 @@ TclCompileDictForCmd(
* Then extract their indices in the LVT.
*/
- varListObj = Tcl_NewObj();
- if (!TclWordKnownAtCompileTime(varsTokenPtr, varListObj) ||
- TCL_OK != Tcl_ListObjLength(NULL, varListObj, &numVars) ||
- numVars != 2) {
- Tcl_DecrRefCount(varListObj);
- return TCL_ERROR;
+ Tcl_DStringInit(&buffer);
+ TclDStringAppendToken(&buffer, &varsTokenPtr[1]);
+ if (Tcl_SplitList(NULL, Tcl_DStringValue(&buffer), &numVars,
+ &argv) != TCL_OK) {
+ Tcl_DStringFree(&buffer);
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
-
- Tcl_ListObjIndex(NULL, varListObj, 0, &varNameObj);
- bytes = Tcl_GetStringFromObj(varNameObj, &numBytes);
- keyVarIndex = LocalScalar(bytes, numBytes, envPtr);
- if (keyVarIndex < 0) {
- Tcl_DecrRefCount(varListObj);
- return TCL_ERROR;
+ Tcl_DStringFree(&buffer);
+ if (numVars != 2) {
+ ckfree(argv);
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
- Tcl_ListObjIndex(NULL, varListObj, 1, &varNameObj);
- bytes = Tcl_GetStringFromObj(varNameObj, &numBytes);
- valueVarIndex = LocalScalar(bytes, numBytes, envPtr);
- if (valueVarIndex < 0) {
- Tcl_DecrRefCount(varListObj);
- return TCL_ERROR;
- }
+ nameChars = strlen(argv[0]);
+ keyVarIndex = LocalScalar(argv[0], nameChars, envPtr);
+ nameChars = strlen(argv[1]);
+ valueVarIndex = LocalScalar(argv[1], nameChars, envPtr);
+ ckfree(argv);
- Tcl_DecrRefCount(varListObj);
+ if ((keyVarIndex < 0) || (valueVarIndex < 0)) {
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ }
/*
* Allocate a temporary variable to store the iterator reference. The
@@ -870,54 +1440,75 @@ TclCompileDictForCmd(
* (at which point it should also have been finished with).
*/
- infoIndex = TclFindCompiledLocal(NULL, 0, 1, procPtr);
+ infoIndex = AnonymousLocal(envPtr);
+ if (infoIndex < 0) {
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ }
/*
* Preparation complete; issue instructions. Note that this code issues
* fixed-sized jumps. That simplifies things a lot!
*
- * First up, get the dictionary and start the iteration. No catching of
- * errors at this point.
+ * First up, initialize the accumulator dictionary if needed.
+ */
+
+ if (collect == TCL_EACH_COLLECT) {
+ PushStringLiteral(envPtr, "");
+ Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+
+ /*
+ * Get the dictionary and start the iteration. No catching of errors at
+ * this point.
*/
CompileWord(envPtr, dictTokenPtr, interp, 2);
- TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr);
- emptyTargetOffset = CurrentOffset(envPtr);
- TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr);
/*
* Now we catch errors from here on so that we can finalize the search
* started by Tcl_DictObjFirst above.
*/
- catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
- TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr);
+ catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr);
ExceptionRangeStarts(envPtr, catchRange);
+ TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr);
+ emptyTargetOffset = CurrentOffset(envPtr);
+ TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr);
+
/*
* Inside the iteration, write the loop variables.
*/
bodyTargetOffset = CurrentOffset(envPtr);
- TclEmitInstInt4( INST_STORE_SCALAR4, keyVarIndex, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- TclEmitInstInt4( INST_STORE_SCALAR4, valueVarIndex, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
+ Emit14Inst( INST_STORE_SCALAR, keyVarIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ Emit14Inst( INST_STORE_SCALAR, valueVarIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
/*
* Set up the loop exception targets.
*/
- loopRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
+ loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
ExceptionRangeStarts(envPtr, loopRange);
/*
* Compile the loop body itself. It should be stack-neutral.
*/
- SetLineInformation(3);
- CompileBody(envPtr, bodyTokenPtr, interp);
- TclEmitOpcode( INST_POP, envPtr);
+ BODY(bodyTokenPtr, 3);
+ if (collect == TCL_EACH_COLLECT) {
+ Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr);
+ 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);
/*
* Both exception target ranges (error and loop) end here.
@@ -933,37 +1524,29 @@ TclCompileDictForCmd(
*/
ExceptionRangeTarget(envPtr, loopRange, continueOffset);
- TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr);
+ TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr);
jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr);
- TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
-
- /*
- * Now do the final cleanup for the no-error case (this is where we break
- * out of the loop to) by force-terminating the iteration (if not already
- * terminated), ditching the exception info and jumping to the last
- * instruction for this command. In theory, this could be done using the
- * "finally" clause (next generated) but this is faster.
- */
-
- ExceptionRangeTarget(envPtr, loopRange, breakOffset);
- TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr);
- TclEmitOpcode( INST_END_CATCH, envPtr);
+ TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr);
endTargetOffset = CurrentOffset(envPtr);
- TclEmitInstInt4( INST_JUMP4, 0, envPtr);
+ TclEmitInstInt1( INST_JUMP1, 0, envPtr);
/*
* Error handler "finally" clause, which force-terminates the iteration
* and rethrows the error.
*/
+ TclAdjustStackDepth(-1, envPtr);
ExceptionRangeTarget(envPtr, catchRange, catchOffset);
- TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
- TclEmitOpcode( INST_PUSH_RESULT, envPtr);
- TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr);
- TclEmitOpcode( INST_END_CATCH, envPtr);
- TclEmitOpcode( INST_RETURN_STK, envPtr);
+ TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
+ TclEmitOpcode( INST_PUSH_RESULT, envPtr);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
+ TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
+ if (collect == TCL_EACH_COLLECT) {
+ TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( collectVar, envPtr);
+ }
+ TclEmitOpcode( INST_RETURN_STK, envPtr);
/*
* Otherwise we're done (the jump after the DICT_FIRST points here) and we
@@ -971,24 +1554,33 @@ TclCompileDictForCmd(
* easy!) Note that we skip the END_CATCH. [Bug 1382528]
*/
- envPtr->currStackDepth = savedStackDepth+2;
jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset;
TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement,
envPtr->codeStart + emptyTargetOffset);
- TclEmitOpcode( INST_POP, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr);
+ jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset;
+ TclUpdateInstInt1AtPc(INST_JUMP1, jumpDisplacement,
+ envPtr->codeStart + endTargetOffset);
+ TclEmitOpcode( INST_POP, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ ExceptionRangeTarget(envPtr, loopRange, breakOffset);
+ TclFinalizeLoopExceptionRange(envPtr, loopRange);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
/*
* Final stage of the command (normal case) is that we push an empty
- * object. This is done last to promote peephole optimization when it's
- * dropped immediately.
+ * object (or push the accumulator as the result object). This is done
+ * last to promote peephole optimization when it's dropped immediately.
*/
- jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset;
- TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement,
- envPtr->codeStart + endTargetOffset);
- PushLiteral(envPtr, "", 0);
+ TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
+ if (collect == TCL_EACH_COLLECT) {
+ Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr);
+ TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( collectVar, envPtr);
+ } else {
+ PushStringLiteral(envPtr, "");
+ }
return TCL_OK;
}
@@ -1001,11 +1593,19 @@ TclCompileDictUpdateCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
+ DefineLineInformation; /* TIP #280 */
int i, dictIndex, numVars, range, infoIndex;
Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr, *tokenPtr;
DictUpdateInfo *duiPtr;
JumpFixup jumpFixup;
- DefineLineInformation; /* TIP #280 */
+
+ /*
+ * There must be at least one argument after the command.
+ */
+
+ if (parsePtr->numWords < 5) {
+ return TCL_ERROR;
+ }
/*
* Parse the command. Expect the following:
@@ -1016,9 +1616,6 @@ TclCompileDictUpdateCmd(
return TCL_ERROR;
}
numVars = (parsePtr->numWords - 3) / 2;
- if (numVars < 1) {
- return TCL_ERROR;
- }
/*
* The dictionary variable must be a local scalar that is knowable at
@@ -1029,7 +1626,7 @@ TclCompileDictUpdateCmd(
dictVarTokenPtr = TokenAfter(parsePtr->tokenPtr);
dictIndex = LocalScalarFromToken(dictVarTokenPtr, envPtr);
if (dictIndex < 0) {
- return TCL_ERROR;
+ goto issueFallback;
}
/*
@@ -1038,45 +1635,32 @@ TclCompileDictUpdateCmd(
* that are to be used.
*/
- duiPtr = (DictUpdateInfo *)
- ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1));
+ duiPtr = ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1));
duiPtr->length = numVars;
- keyTokenPtrs = (Tcl_Token **) TclStackAlloc(interp,
- sizeof(Tcl_Token *) * numVars);
+ keyTokenPtrs = TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars);
tokenPtr = TokenAfter(dictVarTokenPtr);
for (i=0 ; i<numVars ; i++) {
- int index;
-
/*
* Put keys to one side for later compilation to bytecode.
*/
keyTokenPtrs[i] = tokenPtr;
-
- /*
- * Variables first need to be checked for sanity.
- */
-
tokenPtr = TokenAfter(tokenPtr);
- index = LocalScalarFromToken(tokenPtr, envPtr);
- if (index < 0) {
- ckfree((char *) duiPtr);
- TclStackFree(interp, keyTokenPtrs);
- return TCL_ERROR;
- }
/*
- * Stash the index in the auxiliary data.
+ * Stash the index in the auxiliary data (if it is indeed a local
+ * scalar that is resolvable at compile-time).
*/
- duiPtr->varIndices[i] = index;
+ duiPtr->varIndices[i] = LocalScalarFromToken(tokenPtr, envPtr);
+ if (duiPtr->varIndices[i] < 0) {
+ goto failedUpdateInfoAssembly;
+ }
tokenPtr = TokenAfter(tokenPtr);
}
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- ckfree((char *) duiPtr);
- TclStackFree(interp, keyTokenPtrs);
- return TCL_ERROR;
+ goto failedUpdateInfoAssembly;
}
bodyTokenPtr = tokenPtr;
@@ -1090,16 +1674,15 @@ TclCompileDictUpdateCmd(
for (i=0 ; i<numVars ; i++) {
CompileWord(envPtr, keyTokenPtrs[i], interp, 2*i+2);
}
- TclEmitInstInt4( INST_LIST, numVars, envPtr);
- TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr);
- TclEmitInt4( infoIndex, envPtr);
+ TclEmitInstInt4( INST_LIST, numVars, envPtr);
+ TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
- range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
- TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
ExceptionRangeStarts(envPtr, range);
- SetLineInformation(parsePtr->numWords - 1);
- CompileBody(envPtr, bodyTokenPtr, interp);
+ BODY(bodyTokenPtr, parsePtr->numWords - 1);
ExceptionRangeEnds(envPtr, range);
/*
@@ -1107,10 +1690,10 @@ TclCompileDictUpdateCmd(
* the body evaluation: swap them and finish the update code.
*/
- TclEmitOpcode( INST_END_CATCH, envPtr);
- TclEmitInstInt4( INST_REVERSE, 2, envPtr);
- TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
- TclEmitInt4( infoIndex, envPtr);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
+ TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
/*
* Jump around the exceptional termination code.
@@ -1125,14 +1708,14 @@ TclCompileDictUpdateCmd(
*/
ExceptionRangeTarget(envPtr, range, catchOffset);
- TclEmitOpcode( INST_PUSH_RESULT, envPtr);
- TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
- TclEmitOpcode( INST_END_CATCH, envPtr);
- TclEmitInstInt4( INST_REVERSE, 3, envPtr);
+ TclEmitOpcode( INST_PUSH_RESULT, envPtr);
+ TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 3, envPtr);
- TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
- TclEmitInt4( infoIndex, envPtr);
- TclEmitOpcode( INST_RETURN_STK, envPtr);
+ TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
+ TclEmitInvoke(envPtr,INST_RETURN_STK);
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
@@ -1140,6 +1723,16 @@ TclCompileDictUpdateCmd(
}
TclStackFree(interp, keyTokenPtrs);
return TCL_OK;
+
+ /*
+ * Clean up after a failure to create the DictUpdateInfo structure.
+ */
+
+ failedUpdateInfoAssembly:
+ ckfree(duiPtr);
+ TclStackFree(interp, keyTokenPtrs);
+ issueFallback:
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
int
@@ -1151,17 +1744,18 @@ TclCompileDictAppendCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
+ DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int i, dictVarIndex;
- DefineLineInformation; /* TIP #280 */
/*
- * There must be at least two argument after the command. Since we
- * implement using INST_CONCAT1, make sure the number of arguments
- * stays within its range.
+ * There must be at least two argument after the command. And we impose an
+ * (arbirary) safe limit; anyone exceeding it should stop worrying about
+ * speed quite so much. ;-)
*/
- if (parsePtr->numWords<4 || parsePtr->numWords>258) {
+ /* TODO: Consider support for compiling expanded args. */
+ if (parsePtr->numWords<4 || parsePtr->numWords>100) {
return TCL_ERROR;
}
@@ -1172,7 +1766,7 @@ TclCompileDictAppendCmd(
tokenPtr = TokenAfter(parsePtr->tokenPtr);
dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr);
if (dictVarIndex < 0) {
- return TCL_ERROR;
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr,cmdPtr, envPtr);
}
/*
@@ -1185,7 +1779,7 @@ TclCompileDictAppendCmd(
tokenPtr = TokenAfter(tokenPtr);
}
if (parsePtr->numWords > 4) {
- TclEmitInstInt1(INST_CONCAT1, parsePtr->numWords-3, envPtr);
+ TclEmitInstInt1(INST_STR_CONCAT1, parsePtr->numWords-3, envPtr);
}
/*
@@ -1205,28 +1799,290 @@ TclCompileDictLappendCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
+ DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *keyTokenPtr, *valueTokenPtr;
int dictVarIndex;
- DefineLineInformation; /* TIP #280 */
/*
* There must be three arguments after the command.
*/
+ /* TODO: Consider support for compiling expanded args. */
+ /* Probably not. Why is INST_DICT_LAPPEND limited to one value? */
if (parsePtr->numWords != 4) {
return TCL_ERROR;
}
+ /*
+ * Parse the arguments.
+ */
+
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
keyTokenPtr = TokenAfter(varTokenPtr);
valueTokenPtr = TokenAfter(keyTokenPtr);
dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr);
if (dictVarIndex < 0) {
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
+
+ /*
+ * Issue the implementation.
+ */
+
CompileWord(envPtr, keyTokenPtr, interp, 2);
CompileWord(envPtr, valueTokenPtr, interp, 3);
- TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr);
+ TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileDictWithCmd(
+ 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 i, range, varNameTmp = -1, pathTmp = -1, keysTmp, gotPath;
+ int dictVar, bodyIsEmpty = 1;
+ Tcl_Token *varTokenPtr, *tokenPtr;
+ JumpFixup jumpFixup;
+ const char *ptr, *end;
+
+ /*
+ * There must be at least one argument after the command.
+ */
+
+ /* TODO: Consider support for compiling expanded args. */
+ if (parsePtr->numWords < 3) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Parse the command (trivially). Expect the following:
+ * dict with <any (varName)> ?<any> ...? <literal>
+ */
+
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ tokenPtr = TokenAfter(varTokenPtr);
+ for (i=3 ; i<parsePtr->numWords ; i++) {
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ }
+
+ /*
+ * Test if the last word is an empty script; if so, we can compile it in
+ * all cases, but if it is non-empty we need local variable table entries
+ * to hold the temporary variables (used to keep stack usage simple).
+ */
+
+ for (ptr=tokenPtr[1].start,end=ptr+tokenPtr[1].size ; ptr!=end ; ptr++) {
+ if (*ptr!=' ' && *ptr!='\t' && *ptr!='\n' && *ptr!='\r') {
+ if (envPtr->procPtr == NULL) {
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr,
+ envPtr);
+ }
+ bodyIsEmpty = 0;
+ break;
+ }
+ }
+
+ /*
+ * Determine if we're manipulating a dict in a simple local variable.
+ */
+
+ gotPath = (parsePtr->numWords > 3);
+ dictVar = LocalScalarFromToken(varTokenPtr, envPtr);
+
+ /*
+ * Special case: an empty body means we definitely have no need to issue
+ * try-finally style code or to allocate local variable table entries for
+ * storing temporaries. Still need to do both INST_DICT_EXPAND and
+ * INST_DICT_RECOMBINE_* though, because we can't determine if we're free
+ * of traces.
+ */
+
+ if (bodyIsEmpty) {
+ if (dictVar >= 0) {
+ if (gotPath) {
+ /*
+ * Case: Path into dict in LVT with empty body.
+ */
+
+ tokenPtr = TokenAfter(varTokenPtr);
+ for (i=2 ; i<parsePtr->numWords-1 ; i++) {
+ CompileWord(envPtr, tokenPtr, interp, i);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr);
+ Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr);
+ TclEmitInstInt4(INST_OVER, 1, envPtr);
+ TclEmitOpcode( INST_DICT_EXPAND, envPtr);
+ TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
+ } else {
+ /*
+ * Case: Direct dict in LVT with empty body.
+ */
+
+ PushStringLiteral(envPtr, "");
+ Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr);
+ PushStringLiteral(envPtr, "");
+ TclEmitOpcode( INST_DICT_EXPAND, envPtr);
+ TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
+ }
+ } else {
+ if (gotPath) {
+ /*
+ * Case: Path into dict in non-simple var with empty body.
+ */
+
+ tokenPtr = varTokenPtr;
+ for (i=1 ; i<parsePtr->numWords-1 ; i++) {
+ CompileWord(envPtr, tokenPtr, interp, i);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr);
+ TclEmitInstInt4(INST_OVER, 1, envPtr);
+ TclEmitOpcode( INST_LOAD_STK, envPtr);
+ TclEmitInstInt4(INST_OVER, 1, envPtr);
+ TclEmitOpcode( INST_DICT_EXPAND, envPtr);
+ TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr);
+ } else {
+ /*
+ * Case: Direct dict in non-simple var with empty body.
+ */
+
+ CompileWord(envPtr, varTokenPtr, interp, 1);
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_LOAD_STK, envPtr);
+ PushStringLiteral(envPtr, "");
+ TclEmitOpcode( INST_DICT_EXPAND, envPtr);
+ PushStringLiteral(envPtr, "");
+ TclEmitInstInt4(INST_REVERSE, 2, envPtr);
+ TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr);
+ }
+ }
+ PushStringLiteral(envPtr, "");
+ return TCL_OK;
+ }
+
+ /*
+ * OK, we have a non-trivial body. This means that the focus is on
+ * generating a try-finally structure where the INST_DICT_RECOMBINE_* goes
+ * in the 'finally' clause.
+ *
+ * Start by allocating local (unnamed, untraced) working variables.
+ */
+
+ if (dictVar == -1) {
+ varNameTmp = AnonymousLocal(envPtr);
+ }
+ if (gotPath) {
+ pathTmp = AnonymousLocal(envPtr);
+ }
+ keysTmp = AnonymousLocal(envPtr);
+
+ /*
+ * Issue instructions. First, the part to expand the dictionary.
+ */
+
+ if (dictVar == -1) {
+ CompileWord(envPtr, varTokenPtr, interp, 1);
+ Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr);
+ }
+ tokenPtr = TokenAfter(varTokenPtr);
+ if (gotPath) {
+ for (i=2 ; i<parsePtr->numWords-1 ; i++) {
+ CompileWord(envPtr, tokenPtr, interp, i);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr);
+ Emit14Inst( INST_STORE_SCALAR, pathTmp, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+ if (dictVar == -1) {
+ TclEmitOpcode( INST_LOAD_STK, envPtr);
+ } else {
+ Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr);
+ }
+ if (gotPath) {
+ Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr);
+ } else {
+ PushStringLiteral(envPtr, "");
+ }
+ TclEmitOpcode( INST_DICT_EXPAND, envPtr);
+ Emit14Inst( INST_STORE_SCALAR, keysTmp, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+
+ /*
+ * Now the body of the [dict with].
+ */
+
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
+
+ ExceptionRangeStarts(envPtr, range);
+ BODY(tokenPtr, parsePtr->numWords - 1);
+ ExceptionRangeEnds(envPtr, range);
+
+ /*
+ * Now fold the results back into the dictionary in the OK case.
+ */
+
+ TclEmitOpcode( INST_END_CATCH, envPtr);
+ if (dictVar == -1) {
+ Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr);
+ }
+ if (gotPath) {
+ Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr);
+ } else {
+ PushStringLiteral(envPtr, "");
+ }
+ Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr);
+ if (dictVar == -1) {
+ TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr);
+ } else {
+ TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
+ }
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
+
+ /*
+ * Now fold the results back into the dictionary in the exception case.
+ */
+
+ TclAdjustStackDepth(-1, envPtr);
+ ExceptionRangeTarget(envPtr, range, catchOffset);
+ TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
+ TclEmitOpcode( INST_PUSH_RESULT, envPtr);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
+ if (dictVar == -1) {
+ Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr);
+ }
+ if (parsePtr->numWords > 3) {
+ Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr);
+ } else {
+ PushStringLiteral(envPtr, "");
+ }
+ Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr);
+ if (dictVar == -1) {
+ TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr);
+ } else {
+ TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
+ }
+ TclEmitInvoke(envPtr, INST_RETURN_STK);
+
+ /*
+ * Prepare for the start of the next command.
+ */
+
+ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
+ Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
+ (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
+ }
return TCL_OK;
}
@@ -1242,11 +2098,13 @@ TclCompileDictLappendCmd(
* DupDictUpdateInfo: a copy of the auxiliary data
* FreeDictUpdateInfo: none
* PrintDictUpdateInfo: none
+ * DisassembleDictUpdateInfo: none
*
* Side effects:
* DupDictUpdateInfo: allocates memory
* FreeDictUpdateInfo: releases memory
* PrintDictUpdateInfo: none
+ * DisassembleDictUpdateInfo: none
*
*----------------------------------------------------------------------
*/
@@ -1260,7 +2118,7 @@ DupDictUpdateInfo(
dui1Ptr = clientData;
len = sizeof(DictUpdateInfo) + sizeof(int) * (dui1Ptr->length - 1);
- dui2Ptr = (DictUpdateInfo *) ckalloc(len);
+ dui2Ptr = ckalloc(len);
memcpy(dui2Ptr, dui1Ptr, len);
return dui2Ptr;
}
@@ -1289,6 +2147,99 @@ PrintDictUpdateInfo(
Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]);
}
}
+
+static void
+DisassembleDictUpdateInfo(
+ ClientData clientData,
+ Tcl_Obj *dictObj,
+ ByteCode *codePtr,
+ unsigned int pcOffset)
+{
+ DictUpdateInfo *duiPtr = clientData;
+ int i;
+ Tcl_Obj *variables = Tcl_NewObj();
+
+ for (i=0 ; i<duiPtr->length ; i++) {
+ Tcl_ListObjAppendElement(NULL, variables,
+ Tcl_NewIntObj(duiPtr->varIndices[i]));
+ }
+ Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("variables", -1),
+ variables);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileErrorCmd --
+ *
+ * Procedure called to compile the "error" 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 "error" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileErrorCmd(
+ Tcl_Interp *interp, /* Used for context. */
+ 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. */
+{
+ /*
+ * General syntax: [error message ?errorInfo? ?errorCode?]
+ */
+
+ Tcl_Token *tokenPtr;
+ DefineLineInformation; /* TIP #280 */
+
+ if (parsePtr->numWords < 2 || parsePtr->numWords > 4) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Handle the message.
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+
+ /*
+ * Construct the options. Note that -code and -level are not here.
+ */
+
+ if (parsePtr->numWords == 2) {
+ PushStringLiteral(envPtr, "");
+ } else {
+ PushStringLiteral(envPtr, "-errorinfo");
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ if (parsePtr->numWords == 3) {
+ TclEmitInstInt4( INST_LIST, 2, envPtr);
+ } else {
+ PushStringLiteral(envPtr, "-errorcode");
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 3);
+ TclEmitInstInt4( INST_LIST, 4, envPtr);
+ }
+ }
+
+ /*
+ * Issue the error via 'returnImm error 0'.
+ */
+
+ TclEmitInstInt4( INST_RETURN_IMM, TCL_ERROR, envPtr);
+ TclEmitInt4( 0, envPtr);
+ return TCL_OK;
+}
/*
*----------------------------------------------------------------------
@@ -1298,8 +2249,8 @@ PrintDictUpdateInfo(
* Procedure called to compile the "expr" command.
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * 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 "expr" command at
@@ -1343,8 +2294,8 @@ TclCompileExprCmd(
* Procedure called to compile the "for" command.
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * 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 "for" command at
@@ -1364,9 +2315,8 @@ TclCompileForCmd(
{
Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;
JumpFixup jumpEvalCondFixup;
- int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist;
+ int bodyCodeOffset, nextCodeOffset, jumpDist;
int bodyRange, nextRange;
- int savedStackDepth = envPtr->currStackDepth;
DefineLineInformation; /* TIP #280 */
if (parsePtr->numWords != 5) {
@@ -1398,20 +2348,10 @@ TclCompileForCmd(
}
/*
- * Create ExceptionRange records for the body and the "next" command. The
- * "next" command's ExceptionRange supports break but not continue (and
- * has a -1 continueOffset).
- */
-
- bodyRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
- nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
-
- /*
* Inline compile the initial command.
*/
- SetLineInformation (1);
- CompileBody(envPtr, startTokenPtr, interp);
+ BODY(startTokenPtr, 1);
TclEmitOpcode(INST_POP, envPtr);
/*
@@ -1432,44 +2372,37 @@ TclCompileForCmd(
* Compile the loop body.
*/
+ bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange);
- SetLineInformation (4);
- CompileBody(envPtr, bodyTokenPtr, interp);
+ BODY(bodyTokenPtr, 4);
ExceptionRangeEnds(envPtr, bodyRange);
- envPtr->currStackDepth = savedStackDepth + 1;
TclEmitOpcode(INST_POP, envPtr);
/*
- * Compile the "next" subcommand.
+ * Compile the "next" subcommand. Note that this exception range will not
+ * have a continueOffset (other than -1) connected to it; it won't trap
+ * TCL_CONTINUE but rather just TCL_BREAK.
*/
- envPtr->currStackDepth = savedStackDepth;
+ nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
+ envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0;
nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange);
- SetLineInformation (3);
- CompileBody(envPtr, nextTokenPtr, interp);
+ BODY(nextTokenPtr, 3);
ExceptionRangeEnds(envPtr, nextRange);
- envPtr->currStackDepth = savedStackDepth + 1;
TclEmitOpcode(INST_POP, envPtr);
- envPtr->currStackDepth = savedStackDepth;
/*
* Compile the test expression then emit the conditional jump that
* terminates the for.
*/
- testCodeOffset = CurrentOffset(envPtr);
-
- jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
- if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
+ if (TclFixupForwardJumpToHere(envPtr, &jumpEvalCondFixup, 127)) {
bodyCodeOffset += 3;
nextCodeOffset += 3;
- testCodeOffset += 3;
}
- SetLineInformation (2);
- envPtr->currStackDepth = savedStackDepth;
+ SetLineInformation(2);
TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
- envPtr->currStackDepth = savedStackDepth + 1;
jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
if (jumpDist > 127) {
@@ -1490,13 +2423,14 @@ TclCompileForCmd(
ExceptionRangeTarget(envPtr, bodyRange, breakOffset);
ExceptionRangeTarget(envPtr, nextRange, breakOffset);
+ TclFinalizeLoopExceptionRange(envPtr, bodyRange);
+ TclFinalizeLoopExceptionRange(envPtr, nextRange);
/*
* The for command's result is an empty string.
*/
- envPtr->currStackDepth = savedStackDepth;
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
return TCL_OK;
}
@@ -1509,8 +2443,8 @@ TclCompileForCmd(
* Procedure called to compile the "foreach" command.
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * 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 "foreach" command at
@@ -1528,16 +2462,78 @@ TclCompileForeachCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
+ return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr,
+ TCL_EACH_KEEP_NONE);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileLmapCmd --
+ *
+ * Procedure called to compile the "lmap" 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 "lmap" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLmapCmd(
+ 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. */
+{
+ return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr,
+ TCL_EACH_COLLECT);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileEachloopCmd --
+ *
+ * Procedure called to compile the "foreach" and "lmap" commands.
+ *
+ * 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 "foreach" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileEachloopCmd(
+ 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. */
+ int collect) /* Select collecting or accumulating mode
+ * (TCL_EACH_*) */
+{
Proc *procPtr = envPtr->procPtr;
- ForeachInfo *infoPtr = NULL;/* Points to the structure describing this
+ ForeachInfo *infoPtr=NULL; /* Points to the structure describing this
* foreach command. Stored in a AuxData
* record in the ByteCode. */
+
Tcl_Token *tokenPtr, *bodyTokenPtr;
- unsigned char *jumpPc;
- JumpFixup jumpFalseFixup;
- int jumpBackDist, jumpBackOffset, infoIndex, range;
- int numWords, numLists, tempVar, i, j, code = TCL_OK;
- int savedStackDepth = envPtr->currStackDepth;
+ int jumpBackOffset, infoIndex, range;
+ int numWords, numLists, i, j, code = TCL_OK;
Tcl_Obj *varListObj = NULL;
DefineLineInformation; /* TIP #280 */
@@ -1575,12 +2571,12 @@ TclCompileForeachCmd(
*/
numLists = (numWords - 2)/2;
- infoPtr = (ForeachInfo *) ckalloc((unsigned)
- sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *));
+ infoPtr = ckalloc(sizeof(ForeachInfo)
+ + (numLists - 1) * sizeof(ForeachVarList *));
infoPtr->numLists = 0; /* Count this up as we go */
/*
- * Parse each var list into sequence of var names. Don't
+ * Parse each var list into sequence of var names. Don't
* compile the foreach inline if any var name needs substitutions or isn't
* a scalar, or if any var list needs substitutions.
*/
@@ -1598,8 +2594,8 @@ TclCompileForeachCmd(
/*
* If the variable list is empty, we can enter an infinite loop when
- * the interpreted version would not. Take care to ensure this does
- * not happen. [Bug 1671138]
+ * the interpreted version would not. Take care to ensure this does
+ * not happen. [Bug 1671138]
*/
if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) ||
@@ -1609,154 +2605,104 @@ TclCompileForeachCmd(
goto done;
}
- varListPtr = (ForeachVarList *) ckalloc((unsigned)
- sizeof(ForeachVarList) + numVars*sizeof(int));
+ varListPtr = ckalloc(sizeof(ForeachVarList)
+ + (numVars - 1) * sizeof(int));
varListPtr->numVars = numVars;
infoPtr->varLists[i/2] = varListPtr;
infoPtr->numLists++;
for (j = 0; j < numVars; j++) {
Tcl_Obj *varNameObj;
- int numBytes;
const char *bytes;
+ int numBytes, varIndex;
Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj);
bytes = Tcl_GetStringFromObj(varNameObj, &numBytes);
- varListPtr->varIndexes[j] = LocalScalar(bytes, numBytes, envPtr);
- if (varListPtr->varIndexes[j] < 0) {
+ varIndex = LocalScalar(bytes, numBytes, envPtr);
+ if (varIndex < 0) {
code = TCL_ERROR;
goto done;
}
+ varListPtr->varIndexes[j] = varIndex;
}
Tcl_SetObjLength(varListObj, 0);
}
/*
- * Reserve (numLists + 1) temporary variables:
- * - numLists temps to hold each value list
- * - 1 temp for the loop counter (index of next element in each list)
- *
- * At this time we don't try to reuse temporaries; if there are two
- * nonoverlapping foreach loops, they don't share any temps.
+ * We will compile the foreach command.
*/
- tempVar = TclFindCompiledLocal(NULL, 0, 1, procPtr);
- infoPtr->firstValueTemp = tempVar;
- for (i= 1; i < numLists; i++) {
- TclFindCompiledLocal(NULL, 0, 1, procPtr);
- }
- infoPtr->loopCtTemp = TclFindCompiledLocal(NULL, 0, 1, procPtr);
-
- infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr);
+ infoIndex = TclCreateAuxData(infoPtr, &tclNewForeachInfoType, envPtr);
/*
- * Create an exception record to handle [break] and [continue].
+ * Create the collecting object, unshared.
*/
-
- range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
-
+
+ if (collect == TCL_EACH_COLLECT) {
+ TclEmitInstInt4(INST_LIST, 0, envPtr);
+ }
+
/*
- * Evaluate then store each value list in the associated temporary.
+ * Evaluate each value list and leave it on stack.
*/
for (i = 0, tokenPtr = parsePtr->tokenPtr;
i < numWords-1;
i++, tokenPtr = TokenAfter(tokenPtr)) {
if ((i%2 == 0) && (i > 0)) {
- SetLineInformation (i);
- CompileTokens(envPtr, tokenPtr, interp);
- if (tempVar <= 255) {
- TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr);
- } else {
- TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr);
- }
- TclEmitOpcode(INST_POP, envPtr);
- tempVar++;
+ CompileWord(envPtr, tokenPtr, interp, i);
}
}
- /*
- * Initialize the temporary var that holds the count of loop iterations.
- */
-
- TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);
-
- /*
- * Top of loop code: assign each loop variable and check whether
- * to terminate the loop.
- */
-
- ExceptionRangeTarget(envPtr, range, continueOffset);
- TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
-
+ TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr);
+
/*
* Inline compile the loop body.
*/
- SetLineInformation (numWords - 1);
+ range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
+
ExceptionRangeStarts(envPtr, range);
- CompileBody(envPtr, bodyTokenPtr, interp);
+ BODY(bodyTokenPtr, numWords - 1);
ExceptionRangeEnds(envPtr, range);
- envPtr->currStackDepth = savedStackDepth + 1;
- TclEmitOpcode(INST_POP, envPtr);
-
- /*
- * Jump back to the test at the top of the loop. Generate a 4 byte jump if
- * the distance to the test is > 120 bytes. This is conservative and
- * ensures that we won't have to replace this jump if we later need to
- * replace the ifFalse jump with a 4 byte jump.
- */
-
- jumpBackOffset = CurrentOffset(envPtr);
- jumpBackDist = jumpBackOffset-envPtr->exceptArrayPtr[range].continueOffset;
- if (jumpBackDist > 120) {
- TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr);
+
+ if (collect == TCL_EACH_COLLECT) {
+ TclEmitOpcode(INST_LMAP_COLLECT, envPtr);
} else {
- TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
}
/*
- * Fix the target of the jump after the foreach_step test.
+ * Bottom of loop code: assign each loop variable and check whether
+ * to terminate the loop. Set the loop's break target.
*/
- if (TclFixupForwardJumpToHere(envPtr, &jumpFalseFixup, 127)) {
- /*
- * Update the loop body's starting PC offset since it moved down.
- */
-
- envPtr->exceptArrayPtr[range].codeOffset += 3;
-
- /*
- * Update the jump back to the test at the top of the loop since it
- * also moved down 3 bytes.
- */
-
- jumpBackOffset += 3;
- jumpPc = (envPtr->codeStart + jumpBackOffset);
- jumpBackDist += 3;
- if (jumpBackDist > 120) {
- TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc);
- } else {
- TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc);
- }
- }
+ ExceptionRangeTarget(envPtr, range, continueOffset);
+ TclEmitOpcode(INST_FOREACH_STEP, envPtr);
+ ExceptionRangeTarget(envPtr, range, breakOffset);
+ TclFinalizeLoopExceptionRange(envPtr, range);
+ TclEmitOpcode(INST_FOREACH_END, envPtr);
+ TclAdjustStackDepth(-(numLists+2), envPtr);
/*
- * Set the loop's break target.
+ * Set the jumpback distance from INST_FOREACH_STEP to the start of the
+ * body's code. Misuse loopCtTemp for storing the jump size.
*/
-
- ExceptionRangeTarget(envPtr, range, breakOffset);
+
+ jumpBackOffset = envPtr->exceptArrayPtr[range].continueOffset -
+ envPtr->exceptArrayPtr[range].codeOffset;
+ infoPtr->loopCtTemp = -jumpBackOffset;
/*
- * The foreach command's result is an empty string.
+ * The command's result is an empty string if not collecting. If
+ * collecting, it is automatically left on stack after FOREACH_END.
*/
- envPtr->currStackDepth = savedStackDepth;
- PushLiteral(envPtr, "", 0);
- envPtr->currStackDepth = savedStackDepth + 1;
-
- done:
+ if (collect != TCL_EACH_COLLECT) {
+ PushStringLiteral(envPtr, "");
+ }
+
+ done:
if (code == TCL_ERROR) {
if (infoPtr) {
FreeForeachInfo(infoPtr);
@@ -1799,8 +2745,8 @@ DupForeachInfo(
register ForeachVarList *srcListPtr, *dupListPtr;
int numVars, i, j, numLists = srcPtr->numLists;
- dupPtr = (ForeachInfo *) ckalloc((unsigned)
- sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *));
+ dupPtr = ckalloc(sizeof(ForeachInfo)
+ + numLists * sizeof(ForeachVarList *));
dupPtr->numLists = numLists;
dupPtr->firstValueTemp = srcPtr->firstValueTemp;
dupPtr->loopCtTemp = srcPtr->loopCtTemp;
@@ -1808,8 +2754,8 @@ DupForeachInfo(
for (i = 0; i < numLists; i++) {
srcListPtr = srcPtr->varLists[i];
numVars = srcListPtr->numVars;
- dupListPtr = (ForeachVarList *) ckalloc((unsigned)
- sizeof(ForeachVarList) + numVars*sizeof(int));
+ dupListPtr = ckalloc(sizeof(ForeachVarList)
+ + numVars * sizeof(int));
dupListPtr->numVars = numVars;
for (j = 0; j < numVars; j++) {
dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j];
@@ -1850,18 +2796,18 @@ FreeForeachInfo(
for (i = 0; i < numLists; i++) {
listPtr = infoPtr->varLists[i];
- ckfree((char *) listPtr);
+ ckfree(listPtr);
}
- ckfree((char *) infoPtr);
+ ckfree(infoPtr);
}
/*
*----------------------------------------------------------------------
*
- * PrintForeachInfo --
+ * PrintForeachInfo, DisassembleForeachInfo --
*
- * Function to write a human-readable representation of a ForeachInfo
- * structure to stdout for debugging.
+ * Functions to write a human-readable or script-readablerepresentation
+ * of a ForeachInfo structure to a Tcl_Obj for debugging.
*
* Results:
* None.
@@ -1911,846 +2857,141 @@ PrintForeachInfo(
Tcl_AppendToObj(appendObj, "]", -1);
}
}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileIfCmd --
- *
- * Procedure called to compile the "if" 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 "if" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileIfCmd(
- 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. */
-{
- JumpFixupArray jumpFalseFixupArray;
- /* Used to fix the ifFalse jump after each
- * test when its target PC is determined. */
- JumpFixupArray jumpEndFixupArray;
- /* Used to fix the jump after each "then" body
- * to the end of the "if" when that PC is
- * determined. */
- Tcl_Token *tokenPtr, *testTokenPtr;
- int jumpIndex = 0; /* Avoid compiler warning. */
- int jumpFalseDist, numWords, wordIdx, numBytes, j, code;
- const char *word;
- int savedStackDepth = envPtr->currStackDepth;
- /* Saved stack depth at the start of the first
- * test; the envPtr current depth is restored
- * to this value at the start of each test. */
- int realCond = 1; /* Set to 0 for static conditions:
- * "if 0 {..}" */
- int boolVal; /* Value of static condition. */
- int compileScripts = 1;
- DefineLineInformation; /* TIP #280 */
-
- /*
- * Only compile the "if" command if all arguments are simple words, in
- * order to insure correct substitution [Bug 219166]
- */
-
- tokenPtr = parsePtr->tokenPtr;
- wordIdx = 0;
- numWords = parsePtr->numWords;
-
- for (wordIdx = 0; wordIdx < numWords; wordIdx++) {
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- tokenPtr = TokenAfter(tokenPtr);
- }
-
- TclInitJumpFixupArray(&jumpFalseFixupArray);
- TclInitJumpFixupArray(&jumpEndFixupArray);
- code = TCL_OK;
-
- /*
- * Each iteration of this loop compiles one "if expr ?then? body" or
- * "elseif expr ?then? body" clause.
- */
-
- tokenPtr = parsePtr->tokenPtr;
- wordIdx = 0;
- while (wordIdx < numWords) {
- /*
- * Stop looping if the token isn't "if" or "elseif".
- */
-
- word = tokenPtr[1].start;
- numBytes = tokenPtr[1].size;
- if ((tokenPtr == parsePtr->tokenPtr)
- || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) {
- tokenPtr = TokenAfter(tokenPtr);
- wordIdx++;
- } else {
- break;
- }
- if (wordIdx >= numWords) {
- code = TCL_ERROR;
- goto done;
- }
-
- /*
- * Compile the test expression then emit the conditional jump around
- * the "then" part.
- */
-
- envPtr->currStackDepth = savedStackDepth;
- testTokenPtr = tokenPtr;
-
- if (realCond) {
- /*
- * Find out if the condition is a constant.
- */
-
- Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start,
- testTokenPtr[1].size);
- Tcl_IncrRefCount(boolObj);
- code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
- TclDecrRefCount(boolObj);
- if (code == TCL_OK) {
- /*
- * A static condition.
- */
-
- realCond = 0;
- if (!boolVal) {
- compileScripts = 0;
- }
- } else {
- SetLineInformation (wordIdx);
- Tcl_ResetResult(interp);
- TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
- if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
- TclExpandJumpFixupArray(&jumpFalseFixupArray);
- }
- jumpIndex = jumpFalseFixupArray.next;
- jumpFalseFixupArray.next++;
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
- jumpFalseFixupArray.fixup+jumpIndex);
- }
- code = TCL_OK;
- }
-
- /*
- * Skip over the optional "then" before the then clause.
- */
-
- tokenPtr = TokenAfter(testTokenPtr);
- wordIdx++;
- if (wordIdx >= numWords) {
- code = TCL_ERROR;
- goto done;
- }
- if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- word = tokenPtr[1].start;
- numBytes = tokenPtr[1].size;
- if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) {
- tokenPtr = TokenAfter(tokenPtr);
- wordIdx++;
- if (wordIdx >= numWords) {
- code = TCL_ERROR;
- goto done;
- }
- }
- }
-
- /*
- * Compile the "then" command body.
- */
-
- if (compileScripts) {
- SetLineInformation (wordIdx);
- envPtr->currStackDepth = savedStackDepth;
- CompileBody(envPtr, tokenPtr, interp);
- }
-
- if (realCond) {
- /*
- * Jump to the end of the "if" command. Both jumpFalseFixupArray
- * and jumpEndFixupArray are indexed by "jumpIndex".
- */
-
- if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {
- TclExpandJumpFixupArray(&jumpEndFixupArray);
- }
- jumpEndFixupArray.next++;
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
- jumpEndFixupArray.fixup+jumpIndex);
-
- /*
- * Fix the target of the jumpFalse after the test. Generate a 4
- * byte jump if the distance is > 120 bytes. This is conservative,
- * and ensures that we won't have to replace this jump if we later
- * also need to replace the proceeding jump to the end of the "if"
- * with a 4 byte jump.
- */
-
- if (TclFixupForwardJumpToHere(envPtr,
- jumpFalseFixupArray.fixup+jumpIndex, 120)) {
- /*
- * Adjust the code offset for the proceeding jump to the end
- * of the "if" command.
- */
-
- jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
- }
- } else if (boolVal) {
- /*
- * We were processing an "if 1 {...}"; stop compiling scripts.
- */
-
- compileScripts = 0;
- } else {
- /*
- * We were processing an "if 0 {...}"; reset so that the rest
- * (elseif, else) is compiled correctly.
- */
-
- realCond = 1;
- compileScripts = 1;
- }
-
- tokenPtr = TokenAfter(tokenPtr);
- wordIdx++;
- }
-
- /*
- * Restore the current stack depth in the environment; the "else" clause
- * (or its default) will add 1 to this.
- */
-
- envPtr->currStackDepth = savedStackDepth;
-
- /*
- * Check for the optional else clause. Do not compile anything if this was
- * an "if 1 {...}" case.
- */
-
- if ((wordIdx < numWords) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
- /*
- * There is an else clause. Skip over the optional "else" word.
- */
-
- word = tokenPtr[1].start;
- numBytes = tokenPtr[1].size;
- if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) {
- tokenPtr = TokenAfter(tokenPtr);
- wordIdx++;
- if (wordIdx >= numWords) {
- code = TCL_ERROR;
- goto done;
- }
- }
-
- if (compileScripts) {
- /*
- * Compile the else command body.
- */
-
- SetLineInformation (wordIdx);
- CompileBody(envPtr, tokenPtr, interp);
- }
-
- /*
- * Make sure there are no words after the else clause.
- */
-
- wordIdx++;
- if (wordIdx < numWords) {
- code = TCL_ERROR;
- goto done;
- }
- } else {
- /*
- * No else clause: the "if" command's result is an empty string.
- */
-
- if (compileScripts) {
- PushLiteral(envPtr, "", 0);
- }
- }
-
- /*
- * Fix the unconditional jumps to the end of the "if" command.
- */
-
- for (j = jumpEndFixupArray.next; j > 0; j--) {
- jumpIndex = (j - 1); /* i.e. process the closest jump first. */
- if (TclFixupForwardJumpToHere(envPtr,
- jumpEndFixupArray.fixup+jumpIndex, 127)) {
- /*
- * Adjust the immediately preceeding "ifFalse" jump. We moved it's
- * target (just after this jump) down three bytes.
- */
-
- unsigned char *ifFalsePc = envPtr->codeStart
- + jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
- unsigned char opCode = *ifFalsePc;
-
- if (opCode == INST_JUMP_FALSE1) {
- jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1);
- jumpFalseDist += 3;
- TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
- } else if (opCode == INST_JUMP_FALSE4) {
- jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
- jumpFalseDist += 3;
- TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
- } else {
- Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode);
- }
- }
- }
-
- /*
- * Free the jumpFixupArray array if malloc'ed storage was used.
- */
-
- done:
- envPtr->currStackDepth = savedStackDepth + 1;
- TclFreeJumpFixupArray(&jumpFalseFixupArray);
- TclFreeJumpFixupArray(&jumpEndFixupArray);
- return code;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileIncrCmd --
- *
- * Procedure called to compile the "incr" 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 "incr" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-int
-TclCompileIncrCmd(
- 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. */
+static void
+PrintNewForeachInfo(
+ ClientData clientData,
+ Tcl_Obj *appendObj,
+ ByteCode *codePtr,
+ unsigned int pcOffset)
{
- Tcl_Token *varTokenPtr, *incrTokenPtr;
- int simpleVarName, isScalar, localIndex, haveImmValue, immValue;
- DefineLineInformation; /* TIP #280 */
-
- if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
- return TCL_ERROR;
- }
-
- varTokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX|TCL_CREATE_VAR,
- &localIndex, &simpleVarName, &isScalar, 1);
-
- /*
- * If an increment is given, push it, but see first if it's a small
- * integer.
- */
-
- haveImmValue = 0;
- immValue = 1;
- if (parsePtr->numWords == 3) {
- incrTokenPtr = TokenAfter(varTokenPtr);
- if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- const char *word = incrTokenPtr[1].start;
- int numBytes = incrTokenPtr[1].size;
- int code;
- Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes);
- Tcl_IncrRefCount(intObj);
- code = TclGetIntFromObj(NULL, intObj, &immValue);
- TclDecrRefCount(intObj);
- if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) {
- haveImmValue = 1;
- }
- if (!haveImmValue) {
- PushLiteral(envPtr, word, numBytes);
- }
- } else {
- SetLineInformation (2);
- CompileTokens(envPtr, incrTokenPtr, interp);
- }
- } else { /* No incr amount given so use 1. */
- haveImmValue = 1;
- }
-
- /*
- * Emit the instruction to increment the variable.
- */
+ register ForeachInfo *infoPtr = clientData;
+ register ForeachVarList *varsPtr;
+ int i, j;
- if (simpleVarName) {
- if (isScalar) {
- if (localIndex >= 0) {
- if (haveImmValue) {
- TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr);
- TclEmitInt1(immValue, envPtr);
- } else {
- TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr);
- }
- } else {
- if (haveImmValue) {
- TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr);
- } else {
- TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr);
- }
- }
- } else {
- if (localIndex >= 0) {
- if (haveImmValue) {
- TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr);
- TclEmitInt1(immValue, envPtr);
- } else {
- TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr);
- }
- } else {
- if (haveImmValue) {
- TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr);
- } else {
- TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr);
- }
- }
- }
- } else { /* Non-simple variable name. */
- if (haveImmValue) {
- TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr);
- } else {
- TclEmitOpcode(INST_INCR_STK, envPtr);
+ Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+d, vars=",
+ infoPtr->loopCtTemp);
+ for (i=0 ; i<infoPtr->numLists ; i++) {
+ if (i) {
+ Tcl_AppendToObj(appendObj, ",", -1);
}
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileLappendCmd --
- *
- * Procedure called to compile the "lappend" 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 "lappend" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileLappendCmd(
- 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 *varTokenPtr;
- int simpleVarName, isScalar, localIndex, numWords;
- DefineLineInformation; /* TIP #280 */
-
- /*
- * If we're not in a procedure, don't compile.
- */
-
- if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
- }
-
- numWords = parsePtr->numWords;
- if (numWords == 1) {
- return TCL_ERROR;
- }
- if (numWords != 3) {
- /*
- * LAPPEND instructions currently only handle one value appends.
- */
-
- return TCL_ERROR;
- }
-
- /*
- * Decide if we can use a frame slot for the var/array name or if we
- * need to emit code to compute and push the name at runtime. We use a
- * frame slot (entry in the array of local vars) if we are compiling a
- * procedure body and if the name is simple text that does not include
- * namespace qualifiers.
- */
-
- varTokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
- &localIndex, &simpleVarName, &isScalar, 1);
-
- /*
- * If we are doing an assignment, push the new value. In the no values
- * case, create an empty object.
- */
-
- if (numWords > 2) {
- Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr);
- CompileWord(envPtr, valueTokenPtr, interp, 2);
- }
-
- /*
- * Emit instructions to set/get the variable.
- */
-
- /*
- * The *_STK opcodes should be refactored to make better use of existing
- * LOAD/STORE instructions.
- */
-
- if (simpleVarName) {
- if (isScalar) {
- if (localIndex < 0) {
- TclEmitOpcode(INST_LAPPEND_STK, envPtr);
- } else if (localIndex <= 255) {
- TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr);
- }
- } else {
- if (localIndex < 0) {
- TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr);
- } else if (localIndex <= 255) {
- TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr);
+ Tcl_AppendToObj(appendObj, "[", -1);
+ varsPtr = infoPtr->varLists[i];
+ for (j=0 ; j<varsPtr->numVars ; j++) {
+ if (j) {
+ Tcl_AppendToObj(appendObj, ",", -1);
}
+ Tcl_AppendPrintfToObj(appendObj, "%%v%u",
+ (unsigned) varsPtr->varIndexes[j]);
}
- } else {
- TclEmitOpcode(INST_LAPPEND_STK, envPtr);
+ Tcl_AppendToObj(appendObj, "]", -1);
}
-
- return TCL_OK;
}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileLassignCmd --
- *
- * Procedure called to compile the "lassign" 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 "lassign" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-int
-TclCompileLassignCmd(
- 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. */
+static void
+DisassembleForeachInfo(
+ ClientData clientData,
+ Tcl_Obj *dictObj,
+ ByteCode *codePtr,
+ unsigned int pcOffset)
{
- Tcl_Token *tokenPtr;
- int simpleVarName, isScalar, localIndex, numWords, idx;
- DefineLineInformation; /* TIP #280 */
-
- numWords = parsePtr->numWords;
+ register ForeachInfo *infoPtr = clientData;
+ register ForeachVarList *varsPtr;
+ int i, j;
+ Tcl_Obj *objPtr, *innerPtr;
/*
- * Check for command syntax error, but we'll punt that to runtime.
+ * Data stores.
*/
- if (numWords < 3) {
- return TCL_ERROR;
+ objPtr = Tcl_NewObj();
+ for (i=0 ; i<infoPtr->numLists ; i++) {
+ Tcl_ListObjAppendElement(NULL, objPtr,
+ Tcl_NewIntObj(infoPtr->firstValueTemp + i));
}
+ Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("data", -1), objPtr);
/*
- * Generate code to push list being taken apart by [lassign].
+ * Loop counter.
*/
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 1);
+ Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("loop", -1),
+ Tcl_NewIntObj(infoPtr->loopCtTemp));
/*
- * Generate code to assign values from the list to variables.
+ * Assignment targets.
*/
- for (idx=0 ; idx<numWords-2 ; idx++) {
- tokenPtr = TokenAfter(tokenPtr);
-
- /*
- * Generate the next variable name.
- */
-
- PushVarNameWord(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex,
- &simpleVarName, &isScalar, idx+2);
-
- /*
- * Emit instructions to get the idx'th item out of the list value on
- * the stack and assign it to the variable.
- */
-
- if (simpleVarName) {
- if (isScalar) {
- if (localIndex >= 0) {
- TclEmitOpcode(INST_DUP, envPtr);
- TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
- if (localIndex <= 255) {
- TclEmitInstInt1(INST_STORE_SCALAR1,localIndex,envPtr);
- } else {
- TclEmitInstInt4(INST_STORE_SCALAR4,localIndex,envPtr);
- }
- } else {
- TclEmitInstInt4(INST_OVER, 1, envPtr);
- TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
- TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr);
- }
- } else {
- if (localIndex >= 0) {
- TclEmitInstInt4(INST_OVER, 1, envPtr);
- TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
- if (localIndex <= 255) {
- TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr);
- }
- } else {
- TclEmitInstInt4(INST_OVER, 2, envPtr);
- TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
- TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr);
- }
- }
- } else {
- TclEmitInstInt4(INST_OVER, 1, envPtr);
- TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
- TclEmitOpcode(INST_STORE_STK, envPtr);
+ objPtr = Tcl_NewObj();
+ for (i=0 ; i<infoPtr->numLists ; i++) {
+ innerPtr = Tcl_NewObj();
+ varsPtr = infoPtr->varLists[i];
+ for (j=0 ; j<varsPtr->numVars ; j++) {
+ Tcl_ListObjAppendElement(NULL, innerPtr,
+ Tcl_NewIntObj(varsPtr->varIndexes[j]));
}
- TclEmitOpcode(INST_POP, envPtr);
+ Tcl_ListObjAppendElement(NULL, objPtr, innerPtr);
}
-
- /*
- * Generate code to leave the rest of the list on the stack.
- */
-
- TclEmitInstInt4(INST_LIST_RANGE_IMM, idx, envPtr);
- TclEmitInt4(-2, envPtr); /* -2 == "end" */
-
- return TCL_OK;
+ Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr);
}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileLindexCmd --
- *
- * Procedure called to compile the "lindex" 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 "lindex" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-int
-TclCompileLindexCmd(
- 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. */
+static void
+DisassembleNewForeachInfo(
+ ClientData clientData,
+ Tcl_Obj *dictObj,
+ ByteCode *codePtr,
+ unsigned int pcOffset)
{
- Tcl_Token *idxTokenPtr, *valTokenPtr;
- int i, numWords = parsePtr->numWords;
- DefineLineInformation; /* TIP #280 */
-
- /*
- * Quit if too few args.
- */
-
- if (numWords <= 1) {
- return TCL_ERROR;
- }
-
- valTokenPtr = TokenAfter(parsePtr->tokenPtr);
- if (numWords != 3) {
- goto emitComplexLindex;
- }
-
- idxTokenPtr = TokenAfter(valTokenPtr);
- if (idxTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- Tcl_Obj *tmpObj;
- int idx, result;
-
- tmpObj = Tcl_NewStringObj(idxTokenPtr[1].start, idxTokenPtr[1].size);
- result = TclGetIntFromObj(NULL, tmpObj, &idx);
- TclDecrRefCount(tmpObj);
-
- if (result == TCL_OK && idx >= 0) {
- /*
- * All checks have been completed, and we have exactly this
- * construct:
- * lindex <arbitraryValue> <posInt>
- * This is best compiled as a push of the arbitrary value followed
- * by an "immediate lindex" which is the most efficient variety.
- */
-
- CompileWord(envPtr, valTokenPtr, interp, 1);
- TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
- return TCL_OK;
- }
-
- /*
- * If the conversion failed or the value was negative, we just keep on
- * going with the more complex compilation.
- */
- }
+ register ForeachInfo *infoPtr = clientData;
+ register ForeachVarList *varsPtr;
+ int i, j;
+ Tcl_Obj *objPtr, *innerPtr;
/*
- * Push the operands onto the stack.
+ * Jump offset.
*/
- emitComplexLindex:
- for (i=1 ; i<numWords ; i++) {
- CompileWord(envPtr, valTokenPtr, interp, i);
- valTokenPtr = TokenAfter(valTokenPtr);
- }
+ Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("jumpOffset", -1),
+ Tcl_NewIntObj(infoPtr->loopCtTemp));
/*
- * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI if there are
- * multiple index args.
+ * Assignment targets.
*/
- if (numWords == 3) {
- TclEmitOpcode(INST_LIST_INDEX, envPtr);
- } else {
- TclEmitInstInt4(INST_LIST_INDEX_MULTI, numWords-1, envPtr);
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileListCmd --
- *
- * Procedure called to compile the "list" 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 "list" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileListCmd(
- 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 */
-
- /*
- * If we're not in a procedure, don't compile.
- */
-
- if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
- }
-
- if (parsePtr->numWords == 1) {
- /*
- * [list] without arguments just pushes an empty object.
- */
-
- PushLiteral(envPtr, "", 0);
- } else {
- /*
- * Push the all values onto the stack.
- */
-
- Tcl_Token *valueTokenPtr;
- int i, numWords;
-
- numWords = parsePtr->numWords;
-
- valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
- for (i = 1; i < numWords; i++) {
- CompileWord(envPtr, valueTokenPtr, interp, i);
- valueTokenPtr = TokenAfter(valueTokenPtr);
+ objPtr = Tcl_NewObj();
+ for (i=0 ; i<infoPtr->numLists ; i++) {
+ innerPtr = Tcl_NewObj();
+ varsPtr = infoPtr->varLists[i];
+ for (j=0 ; j<varsPtr->numVars ; j++) {
+ Tcl_ListObjAppendElement(NULL, innerPtr,
+ Tcl_NewIntObj(varsPtr->varIndexes[j]));
}
- TclEmitInstInt4(INST_LIST, numWords - 1, envPtr);
+ Tcl_ListObjAppendElement(NULL, objPtr, innerPtr);
}
-
- return TCL_OK;
+ Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr);
}
/*
*----------------------------------------------------------------------
*
- * TclCompileLlengthCmd --
+ * TclCompileFormatCmd --
*
- * Procedure called to compile the "llength" command.
+ * 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.
+ * 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 "llength" command at
+ * Instructions are added to envPtr to execute the "format" command at
* runtime.
*
*----------------------------------------------------------------------
*/
int
-TclCompileLlengthCmd(
+TclCompileFormatCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
@@ -2758,2029 +2999,284 @@ TclCompileLlengthCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
- Tcl_Token *varTokenPtr;
- DefineLineInformation; /* TIP #280 */
-
- if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- }
- varTokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- CompileWord(envPtr, varTokenPtr, interp, 1);
- TclEmitOpcode(INST_LIST_LENGTH, envPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileLsetCmd --
- *
- * Procedure called to compile the "lset" 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 "lset" command at
- * runtime.
- *
- * The general template for execution of the "lset" command is:
- * (1) Instructions to push the variable name, unless the variable is
- * local to the stack frame.
- * (2) If the variable is an array element, instructions to push the
- * array element name.
- * (3) Instructions to push each of zero or more "index" arguments to the
- * stack, followed with the "newValue" element.
- * (4) Instructions to duplicate the variable name and/or array element
- * name onto the top of the stack, if either was pushed at steps (1)
- * and (2).
- * (5) The appropriate INST_LOAD_* instruction to place the original
- * value of the list variable at top of stack.
- * (6) At this point, the stack contains:
- * varName? arrayElementName? index1 index2 ... newValue oldList
- * The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST
- * according as whether there is exactly one index element (LIST) or
- * either zero or else two or more (FLAT). This instruction removes
- * everything from the stack except for the two names and pushes the
- * new value of the variable.
- * (7) Finally, INST_STORE_* stores the new value in the variable and
- * cleans up the stack.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileLsetCmd(
- 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. */
-{
- int tempDepth; /* Depth used for emitting one part of the
- * code burst. */
- Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
- * parse of the variable name. */
- int localIndex; /* Index of var in local var table. */
- int simpleVarName; /* Flag == 1 if var name is simple. */
- int isScalar; /* Flag == 1 if scalar, 0 if array. */
- int i;
- DefineLineInformation; /* TIP #280 */
-
- /*
- * Check argument count.
- */
-
- if (parsePtr->numWords < 3) {
- /*
- * Fail at run time, not in compilation.
- */
-
- return TCL_ERROR;
- }
-
- /*
- * Decide if we can use a frame slot for the var/array name or if we need
- * to emit code to compute and push the name at runtime. We use a frame
- * slot (entry in the array of local vars) if we are compiling a procedure
- * body and if the name is simple text that does not include namespace
- * qualifiers.
- */
-
- varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
- &localIndex, &simpleVarName, &isScalar, 1);
-
- /*
- * Push the "index" args and the new element value.
- */
-
- for (i=2 ; i<parsePtr->numWords ; ++i) {
- varTokenPtr = TokenAfter(varTokenPtr);
- CompileWord(envPtr, varTokenPtr, interp, i);
- }
-
- /*
- * Duplicate the variable name if it's been pushed.
- */
-
- if (!simpleVarName || localIndex < 0) {
- if (!simpleVarName || isScalar) {
- tempDepth = parsePtr->numWords - 2;
- } else {
- tempDepth = parsePtr->numWords - 1;
- }
- TclEmitInstInt4(INST_OVER, tempDepth, envPtr);
- }
-
- /*
- * Duplicate an array index if one's been pushed.
- */
-
- if (simpleVarName && !isScalar) {
- if (localIndex < 0) {
- tempDepth = parsePtr->numWords - 1;
- } else {
- tempDepth = parsePtr->numWords - 2;
- }
- TclEmitInstInt4(INST_OVER, tempDepth, envPtr);
- }
-
- /*
- * Emit code to load the variable's value.
- */
-
- if (!simpleVarName) {
- TclEmitOpcode(INST_LOAD_STK, envPtr);
- } else if (isScalar) {
- if (localIndex < 0) {
- TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
- } else if (localIndex < 0x100) {
- TclEmitInstInt1(INST_LOAD_SCALAR1, localIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_LOAD_SCALAR4, localIndex, envPtr);
- }
- } else {
- if (localIndex < 0) {
- TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
- } else if (localIndex < 0x100) {
- TclEmitInstInt1(INST_LOAD_ARRAY1, localIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_LOAD_ARRAY4, localIndex, envPtr);
- }
- }
-
- /*
- * Emit the correct variety of 'lset' instruction.
- */
-
- if (parsePtr->numWords == 4) {
- TclEmitOpcode(INST_LSET_LIST, envPtr);
- } else {
- TclEmitInstInt4(INST_LSET_FLAT, parsePtr->numWords-1, envPtr);
- }
-
- /*
- * Emit code to put the value back in the variable.
- */
-
- if (!simpleVarName) {
- TclEmitOpcode(INST_STORE_STK, envPtr);
- } else if (isScalar) {
- if (localIndex < 0) {
- TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr);
- } else if (localIndex < 0x100) {
- TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
- }
- } else {
- if (localIndex < 0) {
- TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr);
- } else if (localIndex < 0x100) {
- TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr);
- }
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileRegexpCmd --
- *
- * Procedure called to compile the "regexp" 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 "regexp" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileRegexpCmd(
- 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. */
-{
- Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
- * parse of the RE or string. */
- int i, len, nocase, exact, sawLast, simple;
- char *str;
DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr = parsePtr->tokenPtr;
+ Tcl_Obj **objv, *formatObj, *tmpObj;
+ char *bytes, *start;
+ int i, j, len;
/*
- * We are only interested in compiling simple regexp cases. Currently
- * supported compile cases are:
- * regexp ?-nocase? ?--? staticString $var
- * regexp ?-nocase? ?--? {^staticString$} $var
+ * Don't handle any guaranteed-error cases.
*/
- if (parsePtr->numWords < 3) {
+ if (parsePtr->numWords < 2) {
return TCL_ERROR;
}
- simple = 0;
- nocase = 0;
- sawLast = 0;
- varTokenPtr = parsePtr->tokenPtr;
-
/*
- * We only look for -nocase and -- as options. Everything else gets pushed
- * to runtime execution. This is different than regexp's runtime option
- * handling, but satisfies our stricter needs.
+ * Check if the argument words are all compile-time-known literals; that's
+ * a case we can handle by compiling to a constant.
*/
- for (i = 1; i < parsePtr->numWords - 2; i++) {
- varTokenPtr = TokenAfter(varTokenPtr);
- if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- /*
- * Not a simple string, so punt to runtime.
- */
-
- return TCL_ERROR;
- }
- str = (char *) varTokenPtr[1].start;
- len = varTokenPtr[1].size;
- if ((len == 2) && (str[0] == '-') && (str[1] == '-')) {
- sawLast++;
- i++;
- break;
- } else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) {
- nocase = 1;
- } else {
- /*
- * Not an option we recognize.
- */
-
- return TCL_ERROR;
- }
- }
-
- if ((parsePtr->numWords - i) != 2) {
- /*
- * We don't support capturing to variables.
- */
-
+ formatObj = Tcl_NewObj();
+ Tcl_IncrRefCount(formatObj);
+ tokenPtr = TokenAfter(tokenPtr);
+ if (!TclWordKnownAtCompileTime(tokenPtr, formatObj)) {
+ Tcl_DecrRefCount(formatObj);
return TCL_ERROR;
}
- /*
- * Get the regexp string. If it is not a simple string or can't be
- * converted to a glob pattern, push the word for the INST_REGEXP.
- * Keep changes here in sync with TclCompileSwitchCmd Switch_Regexp.
- */
-
- varTokenPtr = TokenAfter(varTokenPtr);
-
- if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- Tcl_DString ds;
-
- str = (char *) varTokenPtr[1].start;
- len = varTokenPtr[1].size;
- /*
- * If it has a '-', it could be an incorrectly formed regexp command.
- */
-
- if ((*str == '-') && !sawLast) {
- return TCL_ERROR;
- }
-
- if (len == 0) {
- /*
- * The semantics of regexp are always match on re == "".
- */
-
- PushLiteral(envPtr, "1", 1);
- return TCL_OK;
- }
-
- /*
- * Attempt to convert pattern to glob. If successful, push the
- * converted pattern as a literal.
- */
-
- if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact)
- == TCL_OK) {
- simple = 1;
- PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
- Tcl_DStringFree(&ds);
- }
- }
-
- if (!simple) {
- CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2);
- }
-
- /*
- * Push the string arg.
- */
-
- varTokenPtr = TokenAfter(varTokenPtr);
- CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1);
-
- if (simple) {
- if (exact && !nocase) {
- TclEmitOpcode(INST_STR_EQ, envPtr);
- } else {
- TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
- }
- } else {
- /*
- * Pass correct RE compile flags. We use only Int1 (8-bit), but
- * that handles all the flags we want to pass.
- * Don't use TCL_REG_NOSUB as we may have backrefs.
- */
- int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0);
- TclEmitInstInt1(INST_REGEXP, cflags, envPtr);
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileReturnCmd --
- *
- * Procedure called to compile the "return" 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 "return" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileReturnCmd(
- 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. */
-{
- /*
- * General syntax: [return ?-option value ...? ?result?]
- * An even number of words means an explicit result argument is present.
- */
- int level, code, objc, size, status = TCL_OK;
- int numWords = parsePtr->numWords;
- int explicitResult = (0 == (numWords % 2));
- int numOptionWords = numWords - 1 - explicitResult;
- Tcl_Obj *returnOpts, **objv;
- Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
- DefineLineInformation; /* TIP #280 */
-
- /*
- * Check for special case which can always be compiled:
- * return -options <opts> <msg>
- * Unlike the normal [return] compilation, this version does everything at
- * runtime so it can handle arbitrary words and not just literals. Note
- * that if INST_RETURN_STK wasn't already needed for something else
- * ('finally' clause processing) this piece of code would not be present.
- */
-
- if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD)
- && (wordTokenPtr[1].size == 8)
- && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) {
- Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr);
- Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr);
-
- CompileWord(envPtr, optsTokenPtr, interp, 2);
- CompileWord(envPtr, msgTokenPtr, interp, 3);
- TclEmitOpcode(INST_RETURN_STK, envPtr);
- return TCL_OK;
- }
-
- /*
- * Allocate some working space.
- */
-
- objv = (Tcl_Obj **) TclStackAlloc(interp,
- numOptionWords * sizeof(Tcl_Obj *));
-
- /*
- * Scan through the return options. If any are unknown at compile time,
- * there is no value in bytecompiling. Save the option values known in an
- * objv array for merging into a return options dictionary.
- */
-
- for (objc = 0; objc < numOptionWords; objc++) {
- objv[objc] = Tcl_NewObj();
- Tcl_IncrRefCount(objv[objc]);
- if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
- objc++;
- status = TCL_ERROR;
- goto cleanup;
+ 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;
}
- wordTokenPtr = TokenAfter(wordTokenPtr);
- }
- status = TclMergeReturnOptions(interp, objc, objv,
- &returnOpts, &code, &level);
- cleanup:
- while (--objc >= 0) {
- TclDecrRefCount(objv[objc]);
- }
- TclStackFree(interp, objv);
- if (TCL_ERROR == status) {
- /*
- * Something was bogus in the return options. Clear the error message,
- * and report back to the compiler that this must be interpreted at
- * runtime.
- */
-
- Tcl_ResetResult(interp);
- return TCL_ERROR;
}
/*
- * All options are known at compile time, so we're going to bytecompile.
- * Emit instructions to push the result on the stack.
+ * Everything is a literal, so the result is constant too (or an error if
+ * the format is broken). Do the format now.
*/
- if (explicitResult) {
- CompileWord(envPtr, wordTokenPtr, interp, numWords-1);
- } else {
- /*
- * No explict result argument, so default result is empty string.
- */
-
- PushLiteral(envPtr, "", 0);
+ tmpObj = Tcl_Format(interp, Tcl_GetString(formatObj),
+ parsePtr->numWords-2, objv);
+ for (; --i>=0 ;) {
+ Tcl_DecrRefCount(objv[i]);
}
-
- /*
- * Check for optimization: When [return] is in a proc, and there's no
- * enclosing [catch], and there are no return options, then the INST_DONE
- * instruction is equivalent, and may be more efficient.
- */
-
- if (numOptionWords == 0 && envPtr->procPtr != NULL) {
- /*
- * We have default return options and we're in a proc ...
- */
-
- int index = envPtr->exceptArrayNext - 1;
- int enclosingCatch = 0;
-
- while (index >= 0) {
- ExceptionRange range = envPtr->exceptArrayPtr[index];
- if ((range.type == CATCH_EXCEPTION_RANGE)
- && (range.catchOffset == -1)) {
- enclosingCatch = 1;
- break;
- }
- index--;
- }
- if (!enclosingCatch) {
- /*
- * ... and there is no enclosing catch. Issue the maximally
- * efficient exit instruction.
- */
-
- Tcl_DecrRefCount(returnOpts);
- TclEmitOpcode(INST_DONE, envPtr);
- return TCL_OK;
- }
- }
-
- /* Optimize [return -level 0 $x]. */
- Tcl_DictObjSize(NULL, returnOpts, &size);
- if (size == 0 && level == 0 && code == TCL_OK) {
- Tcl_DecrRefCount(returnOpts);
+ ckfree(objv);
+ Tcl_DecrRefCount(formatObj);
+ if (tmpObj == NULL) {
+ TclCompileSyntaxError(interp, envPtr);
return TCL_OK;
}
/*
- * Could not use the optimization, so we push the return options dict, and
- * emit the INST_RETURN_IMM instruction with code and level as operands.
- */
-
- CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts);
- return TCL_OK;
-}
-
-static void
-CompileReturnInternal(
- CompileEnv *envPtr,
- unsigned char op,
- int code,
- int level,
- Tcl_Obj *returnOpts)
-{
- TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr);
- TclEmitInstInt4(op, code, envPtr);
- TclEmitInt4(level, envPtr);
-}
-
-void
-TclCompileSyntaxError(
- Tcl_Interp *interp,
- CompileEnv *envPtr)
-{
- Tcl_Obj *msg = Tcl_GetObjResult(interp);
- int numBytes;
- const char *bytes = TclGetStringFromObj(msg, &numBytes);
-
- TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr);
- CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0,
- Tcl_GetReturnOptions(interp, TCL_ERROR));
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileSetCmd --
- *
- * Procedure called to compile the "set" 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 "set" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileSetCmd(
- 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 *varTokenPtr, *valueTokenPtr;
- int isAssignment, isScalar, simpleVarName, localIndex, numWords;
- DefineLineInformation; /* TIP #280 */
-
- numWords = parsePtr->numWords;
- if ((numWords != 2) && (numWords != 3)) {
- return TCL_ERROR;
- }
- isAssignment = (numWords == 3);
-
- /*
- * Decide if we can use a frame slot for the var/array name or if we need
- * to emit code to compute and push the name at runtime. We use a frame
- * slot (entry in the array of local vars) if we are compiling a procedure
- * body and if the name is simple text that does not include namespace
- * qualifiers.
- */
-
- varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
- &localIndex, &simpleVarName, &isScalar, 1);
-
- /*
- * If we are doing an assignment, push the new value.
- */
-
- if (isAssignment) {
- valueTokenPtr = TokenAfter(varTokenPtr);
- CompileWord(envPtr, valueTokenPtr, interp, 2);
- }
-
- /*
- * Emit instructions to set/get the variable.
- */
-
- if (simpleVarName) {
- if (isScalar) {
- if (localIndex < 0) {
- TclEmitOpcode((isAssignment?
- INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), envPtr);
- } else if (localIndex <= 255) {
- TclEmitInstInt1((isAssignment?
- INST_STORE_SCALAR1 : INST_LOAD_SCALAR1),
- localIndex, envPtr);
- } else {
- TclEmitInstInt4((isAssignment?
- INST_STORE_SCALAR4 : INST_LOAD_SCALAR4),
- localIndex, envPtr);
- }
- } else {
- if (localIndex < 0) {
- TclEmitOpcode((isAssignment?
- INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr);
- } else if (localIndex <= 255) {
- TclEmitInstInt1((isAssignment?
- INST_STORE_ARRAY1 : INST_LOAD_ARRAY1),
- localIndex, envPtr);
- } else {
- TclEmitInstInt4((isAssignment?
- INST_STORE_ARRAY4 : INST_LOAD_ARRAY4),
- localIndex, envPtr);
- }
- }
- } else {
- TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr);
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileStringCmpCmd --
- *
- * Procedure called to compile the simplest and most common form of the
- * "string compare" 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.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileStringCmpCmd(
- 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);
- 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(
- 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.
+ * Not an error, always a constant result, so just push the result as a
+ * literal. Job done.
*/
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 1);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 2);
- TclEmitOpcode(INST_STR_EQ, envPtr);
+ bytes = Tcl_GetStringFromObj(tmpObj, &len);
+ PushLiteral(envPtr, bytes, len);
+ Tcl_DecrRefCount(tmpObj);
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
-TclCompileStringIndexCmd(
- 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;
-
- if (parsePtr->numWords != 3) {
- return TCL_ERROR;
- }
-
- /*
- * Push the two operands onto the stack and then the index operation.
- */
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 1);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 2);
- 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(
- 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;
- int i, length, exactMatch = 0, nocase = 0;
- const char *str;
-
- if (parsePtr->numWords < 3 || parsePtr->numWords > 4) {
- return TCL_ERROR;
- }
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- /*
- * Check if we have a -nocase flag.
- */
-
- if (parsePtr->numWords == 4) {
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- str = tokenPtr[1].start;
- length = tokenPtr[1].size;
- if ((length <= 1) || strncmp(str, "-nocase", (size_t) length)) {
- /*
- * Fail at run time, not in compilation.
- */
-
- return TCL_ERROR;
- }
- nocase = 1;
- tokenPtr = TokenAfter(tokenPtr);
- }
-
- /*
- * Push the strings to match against each other.
- */
-
- for (i = 0; i < 2; i++) {
- if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- str = tokenPtr[1].start;
- length = tokenPtr[1].size;
- if (!nocase && (i == 0)) {
- /*
- * Trivial matches can be done by 'string equal'. If -nocase
- * was specified, we can't do this because INST_STR_EQ has no
- * support for nocase.
- */
-
- Tcl_Obj *copy = Tcl_NewStringObj(str, length);
-
- Tcl_IncrRefCount(copy);
- exactMatch = TclMatchIsTrivial(TclGetString(copy));
- TclDecrRefCount(copy);
- }
- PushLiteral(envPtr, str, length);
- } else {
- SetLineInformation (i+1+nocase);
- CompileTokens(envPtr, tokenPtr, interp);
- }
- tokenPtr = TokenAfter(tokenPtr);
- }
+ checkForStringConcatCase:
/*
- * Push the matcher.
- */
-
- if (exactMatch) {
- TclEmitOpcode(INST_STR_EQ, envPtr);
- } else {
- TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
- }
- 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(
- 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;
-
- if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- }
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- /*
- * Here someone is asking for the length of a static string. Just push
- * the actual character (not byte) length.
- */
-
- char buf[TCL_INTEGER_SPACE];
- int len = Tcl_NumUtfChars(tokenPtr[1].start, tokenPtr[1].size);
-
- len = sprintf(buf, "%d", len);
- PushLiteral(envPtr, buf, len);
- } else {
- SetLineInformation (1);
- CompileTokens(envPtr, tokenPtr, interp);
- TclEmitOpcode(INST_STR_LEN, envPtr);
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileSwitchCmd --
- *
- * Procedure called to compile the "switch" command.
- *
- * Results:
- * Returns TCL_OK for successful compile, or TCL_ERROR to defer
- * evaluation to runtime (either when it is too complex to get the
- * semantics right, or when we know for sure that it is an error but need
- * the error to happen at the right time).
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "switch" command at
- * runtime.
- *
- * FIXME:
- * Stack depths are probably not calculated correctly.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileSwitchCmd(
- 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; /* Pointer to tokens in command. */
- int numWords; /* Number of words in command. */
-
- Tcl_Token *valueTokenPtr; /* Token for the value to switch on. */
- enum {Switch_Exact, Switch_Glob, Switch_Regexp} mode;
- /* What kind of switch are we doing? */
-
- Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */
- Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */
- int *bodyLines; /* Array of line numbers for body list
- * items. */
- int** bodyNext;
- int foundDefault; /* Flag to indicate whether a "default" clause
- * is present. */
-
- JumpFixup *fixupArray; /* Array of forward-jump fixup records. */
- int *fixupTargetArray; /* Array of places for fixups to point at. */
- int fixupCount; /* Number of places to fix up. */
- int contFixIndex; /* Where the first of the jumps due to a group
- * of continuation bodies starts, or -1 if
- * there aren't any. */
- int contFixCount; /* Number of continuation bodies pointing to
- * the current (or next) real body. */
-
- int savedStackDepth = envPtr->currStackDepth;
- int noCase; /* Has the -nocase flag been given? */
- int foundMode = 0; /* Have we seen a mode flag yet? */
- int i, valueIndex;
- DefineLineInformation; /* TIP #280 */
- int* clNext = envPtr->clNext;
-
- /*
- * Only handle the following versions:
- * switch ?--? word {pattern body ...}
- * switch -exact ?--? word {pattern body ...}
- * switch -glob ?--? word {pattern body ...}
- * switch -regexp ?--? word {pattern body ...}
- * switch -- word simpleWordPattern simpleWordBody ...
- * switch -exact -- word simpleWordPattern simpleWordBody ...
- * switch -glob -- word simpleWordPattern simpleWordBody ...
- * switch -regexp -- word simpleWordPattern simpleWordBody ...
- * When the mode is -glob, can also handle a -nocase flag.
+ * 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 off, we don't care how the command's word was generated; we're
- * compiling it anyway! So skip it...
- */
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- valueIndex = 1;
- numWords = parsePtr->numWords-1;
-
- /*
- * Check for options.
- */
-
- noCase = 0;
- mode = Switch_Exact;
- if (numWords == 2) {
- /*
- * There's just the switch value and the bodies list. In that case, we
- * can skip all option parsing and move on to consider switch values
- * and the body list.
- */
-
- goto finishedOptionParse;
- }
-
- /*
- * There must be at least one option, --, because without that there is no
- * way to statically avoid the problems you get from strings-to-be-matched
- * that start with a - (the interpreted code falls apart if it encounters
- * them, so we punt if we *might* encounter them as that is the easiest
- * way of emulating the behaviour).
+ * First, get the state of the system relatively sensible (cleaning up
+ * after our attempt to spot a literal).
*/
- for (; numWords>=3 ; tokenPtr=TokenAfter(tokenPtr),numWords--) {
- register unsigned size = tokenPtr[1].size;
- register const char *chrs = tokenPtr[1].start;
-
- /*
- * We only process literal options, and we assume that -e, -g and -n
- * are unique prefixes of -exact, -glob and -nocase respectively (true
- * at time of writing). Note that -exact and -glob may only be given
- * at most once or we bail out (error case).
- */
-
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || size < 2) {
- return TCL_ERROR;
- }
-
- if ((size <= 6) && !memcmp(chrs, "-exact", size)) {
- if (foundMode) {
- return TCL_ERROR;
- }
- mode = Switch_Exact;
- foundMode = 1;
- valueIndex++;
- continue;
- } else if ((size <= 5) && !memcmp(chrs, "-glob", size)) {
- if (foundMode) {
- return TCL_ERROR;
- }
- mode = Switch_Glob;
- foundMode = 1;
- valueIndex++;
- continue;
- } else if ((size <= 7) && !memcmp(chrs, "-regexp", size)) {
- if (foundMode) {
- return TCL_ERROR;
- }
- mode = Switch_Regexp;
- foundMode = 1;
- valueIndex++;
- continue;
- } else if ((size <= 7) && !memcmp(chrs, "-nocase", size)) {
- noCase = 1;
- valueIndex++;
- continue;
- } else if ((size == 2) && !memcmp(chrs, "--", 2)) {
- valueIndex++;
- break;
- }
-
- /*
- * The switch command has many flags we cannot compile at all (e.g.
- * all the RE-related ones) which we must have encountered. Either
- * that or we have run off the end. The action here is the same: punt
- * to interpreted version.
- */
-
- return TCL_ERROR;
- }
- if (numWords < 3) {
- return TCL_ERROR;
- }
- tokenPtr = TokenAfter(tokenPtr);
- numWords--;
- if (noCase && (mode == Switch_Exact)) {
- /*
- * Can't compile this case; no opcode for case-insensitive equality!
- */
-
- return TCL_ERROR;
+ for (; i>=0 ; i--) {
+ Tcl_DecrRefCount(objv[i]);
}
-
- /*
- * The value to test against is going to always get pushed on the stack.
- * But not yet; we need to verify that the rest of the command is
- * compilable too.
- */
-
- finishedOptionParse:
- valueTokenPtr = tokenPtr;
- /* For valueIndex, see previous loop. */
+ ckfree(objv);
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
tokenPtr = TokenAfter(tokenPtr);
- numWords--;
+ i = 0;
/*
- * Build an array of tokens for the matcher terms and script bodies. Note
- * that in the case of the quoted bodies, this is tricky as we cannot use
- * copies of the string from the input token for the generated tokens (it
- * causes a crash during exception handling). When multiple tokens are
- * available at this point, this is pretty easy.
+ * Now scan through and check for non-%s and non-%% substitutions.
*/
- if (numWords == 1) {
- CONST char *bytes;
- int maxLen, numBytes;
- int bline; /* TIP #280: line of the pattern/action list,
- * and start of list for when tracking the
- * location. This list comes immediately after
- * the value we switch on. */
-
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- bytes = tokenPtr[1].start;
- numBytes = tokenPtr[1].size;
-
- /* Allocate enough space to work in. */
- maxLen = TclMaxListLength(bytes, numBytes, NULL);
- if (maxLen < 2) {
- return TCL_ERROR;
- }
- bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * maxLen);
- bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * maxLen);
- bodyLines = (int *) ckalloc(sizeof(int) * maxLen);
- bodyNext = (int **) ckalloc(sizeof(int*) * maxLen);
-
- bline = mapPtr->loc[eclIndex].line[valueIndex+1];
- numWords = 0;
-
- while (numBytes > 0) {
- CONST char *prevBytes = bytes;
- int literal;
-
- if (TCL_OK != TclFindElement(NULL, bytes, numBytes,
- &(bodyTokenArray[numWords].start), &bytes,
- &(bodyTokenArray[numWords].size), &literal) || !literal) {
- goto abort;
+ for (bytes = Tcl_GetString(formatObj) ; *bytes ; bytes++) {
+ if (*bytes == '%') {
+ bytes++;
+ if (*bytes == 's') {
+ i++;
+ continue;
+ } else if (*bytes == '%') {
+ continue;
}
-
- bodyTokenArray[numWords].type = TCL_TOKEN_TEXT;
- bodyTokenArray[numWords].numComponents = 0;
- bodyToken[numWords] = bodyTokenArray + numWords;
-
- /*
- * TIP #280: Now determine the line the list element starts on
- * (there is no need to do it earlier, due to the possibility of
- * aborting, see above).
- */
-
- TclAdvanceLines(&bline, prevBytes, bodyTokenArray[numWords].start);
- TclAdvanceContinuations (&bline, &clNext,
- bodyTokenArray[numWords].start - envPtr->source);
- bodyLines[numWords] = bline;
- bodyNext[numWords] = clNext;
- TclAdvanceLines(&bline, bodyTokenArray[numWords].start, bytes);
- TclAdvanceContinuations (&bline, &clNext, bytes - envPtr->source);
-
- numBytes -= (bytes - prevBytes);
- numWords++;
- }
- if (numWords % 2) {
- abort:
- ckfree((char *) bodyToken);
- ckfree((char *) bodyTokenArray);
- ckfree((char *) bodyLines);
- ckfree((char *) bodyNext);
+ Tcl_DecrRefCount(formatObj);
return TCL_ERROR;
}
- } else if (numWords % 2 || numWords == 0) {
- /*
- * Odd number of words (>1) available, or no words at all available.
- * Both are error cases, so punt and let the interpreted-version
- * generate the error message. Note that the second case probably
- * should get caught earlier, but it's easy to check here again anyway
- * because it'd cause a nasty crash otherwise.
- */
-
- return TCL_ERROR;
- } else {
- /*
- * Multi-word definition of patterns & actions.
- */
-
- bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords);
- bodyLines = (int *) ckalloc(sizeof(int) * numWords);
- bodyNext = (int **) ckalloc(sizeof(int*) * numWords);
- bodyTokenArray = NULL;
- for (i=0 ; i<numWords ; i++) {
- /*
- * We only handle the very simplest case. Anything more complex is
- * a good reason to go to the interpreted case anyway due to
- * traces, etc.
- */
-
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- ckfree((char *) bodyToken);
- ckfree((char *) bodyLines);
- ckfree((char *) bodyNext);
- return TCL_ERROR;
- }
- bodyToken[i] = tokenPtr+1;
-
- /*
- * TIP #280: Copy line information from regular cmd info.
- */
-
- bodyLines[i] = mapPtr->loc[eclIndex].line[valueIndex+1+i];
- bodyNext[i] = mapPtr->loc[eclIndex].next[valueIndex+1+i];
- tokenPtr = TokenAfter(tokenPtr);
- }
}
/*
- * Fall back to interpreted if the last body is a continuation (it's
- * illegal, but this makes the error happen at the right time).
+ * Check if the number of things to concatenate will fit in a byte.
*/
- if (bodyToken[numWords-1]->size == 1 &&
- bodyToken[numWords-1]->start[0] == '-') {
- ckfree((char *) bodyToken);
- ckfree((char *) bodyLines);
- ckfree((char *) bodyNext);
- if (bodyTokenArray != NULL) {
- ckfree((char *) bodyTokenArray);
- }
+ if (i+2 != parsePtr->numWords || i > 125) {
+ Tcl_DecrRefCount(formatObj);
return TCL_ERROR;
}
/*
- * Now we commit to generating code; the parsing stage per se is done.
- * First, we push the value we're matching against on the stack.
- */
-
- SetLineInformation (valueIndex);
- CompileTokens(envPtr, valueTokenPtr, interp);
-
- /*
- * Check if we can generate a jump table, since if so that's faster than
- * doing an explicit compare with each body. Note that we're definitely
- * over-conservative with determining whether we can do the jump table,
- * but it handles the most common case well enough.
+ * 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.
*/
- if (mode == Switch_Exact) {
- JumptableInfo *jtPtr;
- int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation;
- int mustGenerate, jumpToDefault;
- Tcl_DString buffer;
- Tcl_HashEntry *hPtr;
-
- /*
- * Compile the switch by using a jump table, which is basically a
- * hashtable that maps from literal values to match against to the
- * offset (relative to the INST_JUMP_TABLE instruction) to jump to.
- * The jump table itself is independent of any invokation of the
- * bytecode, and as such is stored in an auxData block.
- *
- * Start by allocating the jump table itself, plus some workspace.
- */
-
- jtPtr = (JumptableInfo *) ckalloc(sizeof(JumptableInfo));
- Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);
- infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr);
- finalFixups = (int *) ckalloc(sizeof(int) * (numWords/2));
- foundDefault = 0;
- mustGenerate = 1;
-
- /*
- * Next, issue the instruction to do the jump, together with what we
- * want to do if things do not work out (jump to either the default
- * clause or the "default" default, which just sets the result to
- * empty). Note that we will come back and rewrite the jump's offset
- * parameter when we know what it should be, and that all jumps we
- * issue are of the wide kind because that makes the code much easier
- * to debug!
- */
-
- jumpLocation = CurrentOffset(envPtr);
- TclEmitInstInt4(INST_JUMP_TABLE, infoIndex, envPtr);
- jumpToDefault = CurrentOffset(envPtr);
- TclEmitInstInt4(INST_JUMP4, 0, envPtr);
-
- for (i=0 ; i<numWords ; i+=2) {
- /*
- * For each arm, we must first work out what to do with the match
- * term.
- */
+ 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 (i!=numWords-2 || bodyToken[numWords-2]->size != 7 ||
- memcmp(bodyToken[numWords-2]->start, "default", 7)) {
/*
- * This is not a default clause, so insert the current
- * location as a target in the jump table (assuming it isn't
- * already there, which would indicate that this clause is
- * probably masked by an earlier one). Note that we use a
- * Tcl_DString here simply because the hash API does not let
- * us specify the string length.
+ * If there is a non-empty literal from the format string,
+ * push it and reset.
*/
- Tcl_DStringInit(&buffer);
- Tcl_DStringAppend(&buffer, bodyToken[i]->start,
- bodyToken[i]->size);
- hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable,
- Tcl_DStringValue(&buffer), &isNew);
- if (isNew) {
- /*
- * First time we've encountered this match clause, so it
- * must point to here.
- */
-
- Tcl_SetHashValue(hPtr, (ClientData)
- (CurrentOffset(envPtr) - jumpLocation));
+ if (len > 0) {
+ PushLiteral(envPtr, b, len);
+ Tcl_DecrRefCount(tmpObj);
+ tmpObj = Tcl_NewObj();
+ i++;
}
- Tcl_DStringFree(&buffer);
- } else {
- /*
- * This is a default clause, so patch up the fallthrough from
- * the INST_JUMP_TABLE instruction to here.
- */
-
- foundDefault = 1;
- isNew = 1;
- TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault,
- envPtr->codeStart+jumpToDefault+1);
- }
-
- /*
- * Now, for each arm we must deal with the body of the clause.
- *
- * If this is a continuation body (never true of a final clause,
- * whether default or not) we're done because the next jump target
- * will also point here, so we advance to the next clause.
- */
-
- if (bodyToken[i+1]->size == 1 && bodyToken[i+1]->start[0] == '-') {
- mustGenerate = 1;
- continue;
- }
-
- /*
- * Also skip this arm if its only match clause is masked. (We
- * could probably be more aggressive about this, but that would be
- * much more difficult to get right.)
- */
-
- if (!isNew && !mustGenerate) {
- continue;
- }
- mustGenerate = 0;
-
- /*
- * Compile the body of the arm.
- */
-
- envPtr->line = bodyLines[i+1]; /* TIP #280 */
- envPtr->clNext = bodyNext[i+1]; /* TIP #280 */
- TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
-
- /*
- * Compile a jump in to the end of the command if this body is
- * anything other than a user-supplied default arm (to either skip
- * over the remaining bodies or the code that generates an empty
- * result).
- */
-
- if (i+2 < numWords || !foundDefault) {
- finalFixups[numRealBodies++] = CurrentOffset(envPtr);
/*
- * Easier by far to issue this jump as a fixed-width jump.
- * Otherwise we'd need to do a lot more (and more awkward)
- * rewriting when we fixed this all up.
+ * Push the code to produce the string that would be
+ * substituted with %s, except we'll be concatenating
+ * directly.
*/
- TclEmitInstInt4(INST_JUMP4, 0, envPtr);
+ CompileWord(envPtr, tokenPtr, interp, j);
+ tokenPtr = TokenAfter(tokenPtr);
+ j++;
+ i++;
}
+ start = bytes + 1;
}
-
- /*
- * We're at the end. If we've not already done so through the
- * processing of a user-supplied default clause, add in a "default"
- * default clause now.
- */
-
- if (!foundDefault) {
- TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault,
- envPtr->codeStart+jumpToDefault+1);
- PushLiteral(envPtr, "", 0);
- }
-
- /*
- * No more instructions to be issued; everything that needs to jump to
- * the end of the command is fixed up at this point.
- */
-
- for (i=0 ; i<numRealBodies ; i++) {
- TclStoreInt4AtPtr(CurrentOffset(envPtr)-finalFixups[i],
- envPtr->codeStart+finalFixups[i]+1);
- }
-
- /*
- * Clean up all our temporary space and return.
- */
-
- ckfree((char *) finalFixups);
- ckfree((char *) bodyToken);
- ckfree((char *) bodyLines);
- ckfree((char *) bodyNext);
- if (bodyTokenArray != NULL) {
- ckfree((char *) bodyTokenArray);
- }
- return TCL_OK;
}
/*
- * Generate a test for each arm.
+ * Handle the case of a trailing literal.
*/
- contFixIndex = -1;
- contFixCount = 0;
- fixupArray = (JumpFixup *) ckalloc(sizeof(JumpFixup) * numWords);
- fixupTargetArray = (int *) ckalloc(sizeof(int) * numWords);
- memset(fixupTargetArray, 0, numWords * sizeof(int));
- fixupCount = 0;
- foundDefault = 0;
- for (i=0 ; i<numWords ; i+=2) {
- int nextArmFixupIndex = -1;
-
- envPtr->currStackDepth = savedStackDepth + 1;
- if (i!=numWords-2 || bodyToken[numWords-2]->size != 7 ||
- memcmp(bodyToken[numWords-2]->start, "default", 7)) {
- /*
- * Generate the test for the arm.
- */
-
- switch (mode) {
- case Switch_Exact:
- TclEmitOpcode(INST_DUP, envPtr);
- TclCompileTokens(interp, bodyToken[i], 1, envPtr);
- TclEmitOpcode(INST_STR_EQ, envPtr);
- break;
- case Switch_Glob:
- TclCompileTokens(interp, bodyToken[i], 1, envPtr);
- TclEmitInstInt4(INST_OVER, 1, envPtr);
- TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr);
- break;
- case Switch_Regexp: {
- int simple = 0, exact = 0;
-
- /*
- * Keep in sync with TclCompileRegexpCmd.
- */
-
- if (bodyToken[i]->type == TCL_TOKEN_TEXT) {
- Tcl_DString ds;
-
- if (bodyToken[i]->size == 0) {
- /*
- * The semantics of regexps are that they always match
- * when the RE == "".
- */
-
- PushLiteral(envPtr, "1", 1);
- break;
- }
-
- /*
- * Attempt to convert pattern to glob. If successful, push
- * the converted pattern.
- */
-
- if (TclReToGlob(NULL, bodyToken[i]->start,
- bodyToken[i]->size, &ds, &exact) == TCL_OK) {
- simple = 1;
- PushLiteral(envPtr, Tcl_DStringValue(&ds),
- Tcl_DStringLength(&ds));
- Tcl_DStringFree(&ds);
- }
- }
- if (!simple) {
- TclCompileTokens(interp, bodyToken[i], 1, envPtr);
- }
-
- TclEmitInstInt4(INST_OVER, 1, envPtr);
- if (simple) {
- if (exact && !noCase) {
- TclEmitOpcode(INST_STR_EQ, envPtr);
- } else {
- TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr);
- }
- } else {
- /*
- * Pass correct RE compile flags. We use only Int1
- * (8-bit), but that handles all the flags we want to
- * pass. Don't use TCL_REG_NOSUB as we may have backrefs
- * or capture vars.
- */
-
- int cflags = TCL_REG_ADVANCED
- | (noCase ? TCL_REG_NOCASE : 0);
-
- TclEmitInstInt1(INST_REGEXP, cflags, envPtr);
- }
- break;
- }
- default:
- Tcl_Panic("unknown switch mode: %d", mode);
- }
-
- /*
- * In a fall-through case, we will jump on _true_ to the place
- * where the body starts (generated later, with guarantee of this
- * ensured earlier; the final body is never a fall-through).
- */
-
- if (bodyToken[i+1]->size==1 && bodyToken[i+1]->start[0]=='-') {
- if (contFixIndex == -1) {
- contFixIndex = fixupCount;
- contFixCount = 0;
- }
- TclEmitForwardJump(envPtr, TCL_TRUE_JUMP,
- fixupArray+contFixIndex+contFixCount);
- fixupCount++;
- contFixCount++;
- continue;
- }
-
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, fixupArray+fixupCount);
- nextArmFixupIndex = fixupCount;
- fixupCount++;
- } else {
- /*
- * Got a default clause; set a flag to inhibit the generation of
- * the jump after the body and the cleanup of the intermediate
- * value that we are switching against.
- *
- * Note that default clauses (which are always terminal clauses)
- * cannot be fall-through clauses as well, since the last clause
- * is never a fall-through clause (which we have already
- * verified).
- */
-
- foundDefault = 1;
- }
-
- /*
- * Generate the body for the arm. This is guaranteed not to be a
- * fall-through case, but it might have preceding fall-through cases,
- * so we must process those first.
- */
-
- if (contFixIndex != -1) {
- int j;
-
- for (j=0 ; j<contFixCount ; j++) {
- fixupTargetArray[contFixIndex+j] = CurrentOffset(envPtr);
- }
- contFixIndex = -1;
- }
+ 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) {
/*
- * Now do the actual compilation. Note that we do not use CompileBody
- * because we may have synthesized the tokens in a non-standard
- * pattern.
+ * Do the concatenation, which produces the result.
*/
- TclEmitOpcode(INST_POP, envPtr);
- envPtr->currStackDepth = savedStackDepth + 1;
- envPtr->line = bodyLines[i+1]; /* TIP #280 */
- envPtr->clNext = bodyNext[i+1]; /* TIP #280 */
- TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
-
- if (!foundDefault) {
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
- fixupArray+fixupCount);
- fixupCount++;
- fixupTargetArray[nextArmFixupIndex] = CurrentOffset(envPtr);
- }
- }
-
- /*
- * Clean up all our temporary space and return.
- */
-
- ckfree((char *) bodyToken);
- ckfree((char *) bodyLines);
- ckfree((char *) bodyNext);
- if (bodyTokenArray != NULL) {
- ckfree((char *) bodyTokenArray);
- }
-
- /*
- * Discard the value we are matching against unless we've had a default
- * clause (in which case it will already be gone due to the code at the
- * start of processing an arm, guaranteed) and make the result of the
- * command an empty string.
- */
-
- if (!foundDefault) {
- TclEmitOpcode(INST_POP, envPtr);
- PushLiteral(envPtr, "", 0);
- }
-
- /*
- * Do jump fixups for arms that were executed. First, fill in the jumps of
- * all jumps that don't point elsewhere to point to here.
- */
-
- for (i=0 ; i<fixupCount ; i++) {
- if (fixupTargetArray[i] == 0) {
- fixupTargetArray[i] = envPtr->codeNext-envPtr->codeStart;
- }
- }
-
- /*
- * Now scan backwards over all the jumps (all of which are forward jumps)
- * doing each one. When we do one and there is a size changes, we must
- * scan back over all the previous ones and see if they need adjusting
- * before proceeding with further jump fixups (the interleaved nature of
- * all the jumps makes this impossible to do without nested loops).
- */
-
- for (i=fixupCount-1 ; i>=0 ; i--) {
- if (TclFixupForwardJump(envPtr, &fixupArray[i],
- fixupTargetArray[i] - fixupArray[i].codeOffset, 127)) {
- int j;
-
- for (j=i-1 ; j>=0 ; j--) {
- if (fixupTargetArray[j] > fixupArray[i].codeOffset) {
- fixupTargetArray[j] += 3;
- }
- }
- }
- }
- ckfree((char *) fixupArray);
- ckfree((char *) fixupTargetArray);
-
- envPtr->currStackDepth = savedStackDepth + 1;
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * DupJumptableInfo, FreeJumptableInfo --
- *
- * Functions to duplicate, release and print a jump-table created for use
- * with the INST_JUMP_TABLE instruction.
- *
- * Results:
- * DupJumptableInfo: a copy of the jump-table
- * FreeJumptableInfo: none
- * PrintJumptableInfo: none
- *
- * Side effects:
- * DupJumptableInfo: allocates memory
- * FreeJumptableInfo: releases memory
- * PrintJumptableInfo: none
- *
- *----------------------------------------------------------------------
- */
-
-static ClientData
-DupJumptableInfo(
- ClientData clientData)
-{
- JumptableInfo *jtPtr = clientData;
- JumptableInfo *newJtPtr = (JumptableInfo *)
- ckalloc(sizeof(JumptableInfo));
- Tcl_HashEntry *hPtr, *newHPtr;
- Tcl_HashSearch search;
- int isNew;
-
- Tcl_InitHashTable(&newJtPtr->hashTable, TCL_STRING_KEYS);
- hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
- while (hPtr != NULL) {
- newHPtr = Tcl_CreateHashEntry(&newJtPtr->hashTable,
- Tcl_GetHashKey(&jtPtr->hashTable, hPtr), &isNew);
- Tcl_SetHashValue(newHPtr, Tcl_GetHashValue(hPtr));
- }
- return newJtPtr;
-}
-
-static void
-FreeJumptableInfo(
- ClientData clientData)
-{
- JumptableInfo *jtPtr = clientData;
-
- Tcl_DeleteHashTable(&jtPtr->hashTable);
- ckfree((char *) jtPtr);
-}
-
-static void
-PrintJumptableInfo(
- ClientData clientData,
- Tcl_Obj *appendObj,
- ByteCode *codePtr,
- unsigned int pcOffset)
-{
- register JumptableInfo *jtPtr = clientData;
- Tcl_HashEntry *hPtr;
- Tcl_HashSearch search;
- const char *keyPtr;
- int offset, i = 0;
-
- hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
- for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) {
- keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
- offset = PTR2INT(Tcl_GetHashValue(hPtr));
-
- if (i++) {
- Tcl_AppendToObj(appendObj, ", ", -1);
- if (i%4==0) {
- Tcl_AppendToObj(appendObj, "\n\t\t", -1);
- }
- }
- Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %d",
- keyPtr, pcOffset + offset);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileWhileCmd --
- *
- * Procedure called to compile the "while" 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 "while" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileWhileCmd(
- 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 *testTokenPtr, *bodyTokenPtr;
- JumpFixup jumpEvalCondFixup;
- int testCodeOffset, bodyCodeOffset, jumpDist, range, code, boolVal;
- int savedStackDepth = envPtr->currStackDepth;
- int loopMayEnd = 1; /* This is set to 0 if it is recognized as an
- * infinite loop. */
- Tcl_Obj *boolObj;
- DefineLineInformation; /* TIP #280 */
-
- if (parsePtr->numWords != 3) {
- return TCL_ERROR;
- }
-
- /*
- * If the test expression requires substitutions, don't compile the while
- * command inline. E.g., the expression might cause the loop to never
- * execute or execute forever, as in "while "$x < 5" {}".
- *
- * Bail out also if the body expression requires substitutions in order to
- * insure correct behaviour [Bug 219166]
- */
-
- testTokenPtr = TokenAfter(parsePtr->tokenPtr);
- bodyTokenPtr = TokenAfter(testTokenPtr);
-
- if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
- || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
- return TCL_ERROR;
- }
-
- /*
- * Find out if the condition is a constant.
- */
-
- boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size);
- Tcl_IncrRefCount(boolObj);
- code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
- TclDecrRefCount(boolObj);
- if (code == TCL_OK) {
- if (boolVal) {
- /*
- * It is an infinite loop; flag it so that we generate a more
- * efficient body.
- */
-
- loopMayEnd = 0;
- } else {
- /*
- * This is an empty loop: "while 0 {...}" or such. Compile no
- * bytecodes.
- */
-
- goto pushResult;
- }
- }
-
- /*
- * Create a ExceptionRange record for the loop body. This is used to
- * implement break and continue.
- */
-
- range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
-
- /*
- * Jump to the evaluation of the condition. This code uses the "loop
- * rotation" optimisation (which eliminates one branch from the loop).
- * "while cond body" produces then:
- * goto A
- * B: body : bodyCodeOffset
- * A: cond -> result : testCodeOffset, continueOffset
- * if (result) goto B
- *
- * The infinite loop "while 1 body" produces:
- * B: body : all three offsets here
- * goto B
- */
-
- if (loopMayEnd) {
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);
- testCodeOffset = 0; /* Avoid compiler warning. */
+ TclEmitInstInt1(INST_STR_CONCAT1, i, envPtr);
} else {
/*
- * Make sure that the first command in the body is preceded by an
- * INST_START_CMD, and hence counted properly. [Bug 1752146]
+ * 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...)
*/
- envPtr->atCmdStart = 0;
- testCodeOffset = CurrentOffset(envPtr);
- }
-
- /*
- * Compile the loop body.
- */
-
- SetLineInformation (2);
- bodyCodeOffset = ExceptionRangeStarts(envPtr, range);
- CompileBody(envPtr, bodyTokenPtr, interp);
- ExceptionRangeEnds(envPtr, range);
- envPtr->currStackDepth = savedStackDepth + 1;
- TclEmitOpcode(INST_POP, envPtr);
-
- /*
- * Compile the test expression then emit the conditional jump that
- * terminates the while. We already know it's a simple word.
- */
-
- if (loopMayEnd) {
- testCodeOffset = CurrentOffset(envPtr);
- jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
- if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
- bodyCodeOffset += 3;
- testCodeOffset += 3;
- }
- envPtr->currStackDepth = savedStackDepth;
- SetLineInformation (1);
- TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
- envPtr->currStackDepth = savedStackDepth + 1;
-
- jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
- if (jumpDist > 127) {
- TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
- } else {
- TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
- }
- } else {
- jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
- if (jumpDist > 127) {
- TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr);
- } else {
- TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr);
- }
+ TclEmitOpcode(INST_DUP, envPtr);
+ PushStringLiteral(envPtr, "");
+ TclEmitOpcode(INST_STR_EQ, envPtr);
+ TclEmitOpcode(INST_POP, envPtr);
}
-
- /*
- * Set the loop's body, continue and break offsets.
- */
-
- envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
- envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset;
- ExceptionRangeTarget(envPtr, range, breakOffset);
-
- /*
- * The while command's result is an empty string.
- */
-
- pushResult:
- envPtr->currStackDepth = savedStackDepth;
- PushLiteral(envPtr, "", 0);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * LocalScalar(FromToken) --
+ * TclLocalScalarFromToken --
*
* Get the index into the table of compiled locals that corresponds
* to a local scalar variable name.
*
* Results:
* Returns the non-negative integer index value into the table of
- * compiled locals corresponding to a local scalar variable name.
- * If the arguments passed in do not identify a local scalar variable
- * then return -1.
+ * compiled locals corresponding to a local scalar variable name.
+ * If the arguments passed in do not identify a local scalar variable
+ * then return -1.
*
* Side effects:
- * May add an entry into the table of compiled locals.
+ * May add an entery into the table of compiled locals.
*
*----------------------------------------------------------------------
*/
-static int
-LocalScalarFromToken(
+int
+TclLocalScalarFromToken(
Tcl_Token *tokenPtr,
CompileEnv *envPtr)
{
- int isSimple, isScalar, index;
+ int isScalar, index;
- PushVarName(NULL, tokenPtr, envPtr, TCL_CREATE_VAR, &index,
- &isSimple, &isScalar, 0 /* ignored */, NULL /* ignored */);
+ TclPushVarName(NULL, tokenPtr, envPtr, TCL_NO_ELEMENT, &index, &isScalar);
if (!isScalar) {
index = -1;
}
return index;
}
-static int
-LocalScalar(
+int
+TclLocalScalar(
const char *bytes,
int numBytes,
CompileEnv *envPtr)
{
- Tcl_Token token[2] = {{TCL_TOKEN_SIMPLE_WORD, NULL, 0, 1},
- {TCL_TOKEN_TEXT, NULL, 0, 0}};
+ Tcl_Token token[2] = {{TCL_TOKEN_SIMPLE_WORD, NULL, 0, 1},
+ {TCL_TOKEN_TEXT, NULL, 0, 0}};
token[1].start = bytes;
token[1].size = numBytes;
- return LocalScalarFromToken(token, envPtr);
+ return TclLocalScalarFromToken(token, envPtr);
}
/*
*----------------------------------------------------------------------
*
- * PushVarName --
+ * TclPushVarName --
*
* Procedure used in the compiling where pushing a variable name is
* necessary (append, lappend, set).
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * The values written to *localIndexPtr and *isScalarPtr signal to
+ * the caller what the instructions emitted by this routine will do:
+ *
+ * *isScalarPtr (*localIndexPtr < 0)
+ * 1 1 Push the varname on the stack. (Stack +1)
+ * 1 0 *localIndexPtr is the index of the compiled
+ * local for this varname. No instructions
+ * emitted. (Stack +0)
+ * 0 1 Push part1 and part2 names of array element
+ * on the stack. (Stack +2)
+ * 0 0 *localIndexPtr is the index of the compiled
+ * local for this array. Element name is pushed
+ * on the stack. (Stack +1)
*
* Side effects:
- * Instructions are added to envPtr to execute the "set" command at
- * runtime.
+ * Instructions are added to envPtr.
*
*----------------------------------------------------------------------
*/
-static int
-PushVarName(
+void
+TclPushVarName(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Token *varTokenPtr, /* Points to a variable token. */
CompileEnv *envPtr, /* Holds resulting instructions. */
- int flags, /* TCL_CREATE_VAR or TCL_NO_LARGE_INDEX. */
+ int flags, /* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */
int *localIndexPtr, /* Must not be NULL. */
- int *simpleVarNamePtr, /* Must not be NULL. */
- int *isScalarPtr, /* Must not be NULL. */
- int line, /* Line the token starts on. */
- int* clNext) /* Reference to offset of next hidden cont. line */
+ int *isScalarPtr) /* Must not be NULL. */
{
register const char *p;
const char *name, *elName;
@@ -4826,14 +3322,13 @@ PushVarName(
}
}
- if (interp && (elName != NULL) && elNameChars) {
+ if (!(flags & TCL_NO_ELEMENT) && (elName != NULL) && elNameChars) {
/*
* An array element, the element name is a simple string:
* assemble the corresponding token.
*/
- elemTokenPtr = (Tcl_Token *) TclStackAlloc(interp,
- sizeof(Tcl_Token));
+ elemTokenPtr = TclStackAlloc(interp, sizeof(Tcl_Token));
allocedTokens = 1;
elemTokenPtr->type = TCL_TOKEN_TEXT;
elemTokenPtr->start = elName;
@@ -4846,7 +3341,6 @@ PushVarName(
&& (varTokenPtr[1].type == TCL_TOKEN_TEXT)
&& (varTokenPtr[n].type == TCL_TOKEN_TEXT)
&& (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) {
-
/*
* Check for parentheses inside first token.
*/
@@ -4869,9 +3363,9 @@ PushVarName(
*/
if (varTokenPtr[n].size == 1) {
- --n;
+ n--;
} else {
- --varTokenPtr[n].size;
+ varTokenPtr[n].size--;
removedParen = n;
}
@@ -4881,14 +3375,14 @@ PushVarName(
remainingChars = (varTokenPtr[2].start - p) - 1;
elNameChars = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 1;
- if (remainingChars) {
+ if (!(flags & TCL_NO_ELEMENT)) {
+ if (remainingChars) {
/*
* Make a first token with the extra characters in the first
* token.
*/
- elemTokenPtr = (Tcl_Token *) TclStackAlloc(interp,
- n * sizeof(Tcl_Token));
+ elemTokenPtr = TclStackAlloc(interp, n * sizeof(Tcl_Token));
allocedTokens = 1;
elemTokenPtr->type = TCL_TOKEN_TEXT;
elemTokenPtr->start = elName;
@@ -4902,13 +3396,14 @@ PushVarName(
memcpy(elemTokenPtr+1, varTokenPtr+2,
(n-1) * sizeof(Tcl_Token));
- } else {
+ } else {
/*
* Use the already available tokens.
*/
elemTokenPtr = &varTokenPtr[2];
elemTokenCount = n - 1;
+ }
}
}
}
@@ -4919,6 +3414,7 @@ PushVarName(
*/
int hasNsQualifiers = 0;
+
for (i = 0, p = name; i < nameChars; i++, p++) {
if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) {
hasNsQualifiers = 1;
@@ -4932,10 +3428,8 @@ PushVarName(
* push its name and look it up at runtime.
*/
- if ((envPtr->procPtr != NULL) && !hasNsQualifiers) {
- localIndex = TclFindCompiledLocal(name, nameChars,
- /*create*/ flags & TCL_CREATE_VAR,
- envPtr->procPtr);
+ if (!hasNsQualifiers) {
+ localIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
/*
* We'll push the name.
@@ -4949,16 +3443,16 @@ PushVarName(
}
/*
- * Compile the element script, if any.
+ * Compile the element script, if any, and only if not inhibited. [Bug
+ * 3600328]
*/
- if (interp && elName != NULL) {
+ if (elName != NULL && !(flags & TCL_NO_ELEMENT)) {
if (elNameChars) {
- envPtr->line = line;
- envPtr->clNext = clNext;
- TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr);
+ TclCompileTokens(interp, elemTokenPtr, elemTokenCount,
+ envPtr);
} else {
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
}
}
} else if (interp) {
@@ -4966,1415 +3460,17 @@ PushVarName(
* The var name isn't simple: compile and push it.
*/
- envPtr->line = line;
- envPtr->clNext = clNext;
CompileTokens(envPtr, varTokenPtr, interp);
}
if (removedParen) {
- ++varTokenPtr[removedParen].size;
+ varTokenPtr[removedParen].size++;
}
if (allocedTokens) {
TclStackFree(interp, elemTokenPtr);
}
*localIndexPtr = localIndex;
- *simpleVarNamePtr = simpleVarName;
*isScalarPtr = (elName == NULL);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CompileUnaryOpCmd --
- *
- * Utility routine to compile the unary operator commands.
- *
- * 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 compiled command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-CompileUnaryOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- int instruction,
- CompileEnv *envPtr)
-{
- Tcl_Token *tokenPtr;
- DefineLineInformation; /* TIP #280 */
-
- if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- }
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 1);
- TclEmitOpcode(instruction, envPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CompileAssociativeBinaryOpCmd --
- *
- * Utility routine to compile the binary operator commands that accept an
- * arbitrary number of arguments, and that are associative operations.
- * Because of the associativity, we may combine operations from right to
- * left, saving us any effort of re-ordering the arguments on the stack
- * after substitutions are completed.
- *
- * 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 compiled command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-CompileAssociativeBinaryOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- const char *identity,
- int instruction,
- CompileEnv *envPtr)
-{
- Tcl_Token *tokenPtr = parsePtr->tokenPtr;
- DefineLineInformation; /* TIP #280 */
- int words;
-
- for (words=1 ; words<parsePtr->numWords ; words++) {
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, words);
- }
- if (parsePtr->numWords <= 2) {
- PushLiteral(envPtr, identity, -1);
- words++;
- }
- if (words > 3) {
- /*
- * Reverse order of arguments to get precise agreement with
- * [expr] in calcuations, including roundoff errors.
- */
- TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
- }
- while (--words > 1) {
- TclEmitOpcode(instruction, envPtr);
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CompileStrictlyBinaryOpCmd --
- *
- * Utility routine to compile the binary operator commands, that strictly
- * accept exactly two arguments.
- *
- * 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 compiled command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-CompileStrictlyBinaryOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- int instruction,
- CompileEnv *envPtr)
-{
- if (parsePtr->numWords != 3) {
- return TCL_ERROR;
- }
- return CompileAssociativeBinaryOpCmd(interp, parsePtr,
- NULL, instruction, envPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CompileComparisonOpCmd --
- *
- * Utility routine to compile the n-ary comparison operator commands.
- *
- * 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 compiled command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-CompileComparisonOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- int instruction,
- CompileEnv *envPtr)
-{
- Tcl_Token *tokenPtr;
- DefineLineInformation; /* TIP #280 */
-
- if (parsePtr->numWords < 3) {
- PushLiteral(envPtr, "1", 1);
- } else if (parsePtr->numWords == 3) {
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 1);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 2);
- TclEmitOpcode(instruction, envPtr);
- } else if (envPtr->procPtr == NULL) {
- /*
- * No local variable space!
- */
-
- return TCL_ERROR;
- } else {
- int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr->procPtr);
- int words;
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- 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);
- }
- 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);
- }
- 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);
- }
- }
- TclEmitOpcode(instruction, envPtr);
- }
- for (; words>3 ; words--) {
- TclEmitOpcode(INST_BITAND, envPtr);
- }
-
- /*
- * Drop the value from the temp variable; retaining that reference
- * 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);
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompile*OpCmd --
- *
- * Procedures called to compile the corresponding "::tcl::mathop::*"
- * commands. These are all wrappers around the utility operator command
- * compiler functions, except for the compilers for subtraction and
- * division, which are special.
- *
- * 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 compiled command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileInvertOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileUnaryOpCmd(interp, parsePtr, INST_BITNOT, envPtr);
-}
-
-int
-TclCompileNotOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileUnaryOpCmd(interp, parsePtr, INST_LNOT, envPtr);
-}
-
-int
-TclCompileAddOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_ADD,
- envPtr);
-}
-
-int
-TclCompileMulOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileAssociativeBinaryOpCmd(interp, parsePtr, "1", INST_MULT,
- envPtr);
-}
-
-int
-TclCompileAndOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileAssociativeBinaryOpCmd(interp, parsePtr, "-1", INST_BITAND,
- envPtr);
-}
-
-int
-TclCompileOrOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITOR,
- envPtr);
-}
-
-int
-TclCompileXorOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITXOR,
- envPtr);
-}
-
-int
-TclCompilePowOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- /*
- * This one has its own implementation because the ** operator is
- * the only one with right associativity.
- */
- Tcl_Token *tokenPtr = parsePtr->tokenPtr;
- DefineLineInformation; /* TIP #280 */
- int words;
-
- for (words=1 ; words<parsePtr->numWords ; words++) {
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, words);
- }
- if (parsePtr->numWords <= 2) {
- PushLiteral(envPtr, "1", 1);
- words++;
- }
- while (--words > 1) {
- TclEmitOpcode(INST_EXPON, envPtr);
- }
- return TCL_OK;
-}
-
-int
-TclCompileLshiftOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LSHIFT, envPtr);
-}
-
-int
-TclCompileRshiftOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_RSHIFT, envPtr);
-}
-
-int
-TclCompileModOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_MOD, envPtr);
-}
-
-int
-TclCompileNeqOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_NEQ, envPtr);
-}
-
-int
-TclCompileStrneqOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_STR_NEQ, envPtr);
-}
-
-int
-TclCompileInOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_IN, envPtr);
-}
-
-int
-TclCompileNiOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_NOT_IN,
- envPtr);
-}
-
-int
-TclCompileLessOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileComparisonOpCmd(interp, parsePtr, INST_LT, envPtr);
-}
-
-int
-TclCompileLeqOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileComparisonOpCmd(interp, parsePtr, INST_LE, envPtr);
-}
-
-int
-TclCompileGreaterOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileComparisonOpCmd(interp, parsePtr, INST_GT, envPtr);
-}
-
-int
-TclCompileGeqOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileComparisonOpCmd(interp, parsePtr, INST_GE, envPtr);
-}
-
-int
-TclCompileEqOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileComparisonOpCmd(interp, parsePtr, INST_EQ, envPtr);
-}
-
-int
-TclCompileStreqOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- return CompileComparisonOpCmd(interp, parsePtr, INST_STR_EQ, envPtr);
-}
-
-int
-TclCompileMinusOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- Tcl_Token *tokenPtr = parsePtr->tokenPtr;
- DefineLineInformation; /* TIP #280 */
- int words;
-
- if (parsePtr->numWords == 1) {
- /* Fallback to direct eval to report syntax error */
- return TCL_ERROR;
- }
- for (words=1 ; words<parsePtr->numWords ; words++) {
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, words);
- }
- if (words == 2) {
- TclEmitOpcode(INST_UMINUS, envPtr);
- return TCL_OK;
- }
- if (words == 3) {
- TclEmitOpcode(INST_SUB, envPtr);
- return TCL_OK;
- }
- /*
- * Reverse order of arguments to get precise agreement with
- * [expr] in calcuations, including roundoff errors.
- */
- TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
- while (--words > 1) {
- TclEmitInstInt4(INST_REVERSE, 2, envPtr);
- TclEmitOpcode(INST_SUB, envPtr);
- }
- return TCL_OK;
-}
-
-int
-TclCompileDivOpCmd(
- Tcl_Interp *interp,
- Tcl_Parse *parsePtr,
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- Tcl_Token *tokenPtr = parsePtr->tokenPtr;
- DefineLineInformation; /* TIP #280 */
- int words;
-
- if (parsePtr->numWords == 1) {
- /* Fallback to direct eval to report syntax error */
- return TCL_ERROR;
- }
- if (parsePtr->numWords == 2) {
- PushLiteral(envPtr, "1.0", 3);
- }
- for (words=1 ; words<parsePtr->numWords ; words++) {
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, words);
- }
- if (words <= 3) {
- TclEmitOpcode(INST_DIV, envPtr);
- return TCL_OK;
- }
- /*
- * Reverse order of arguments to get precise agreement with
- * [expr] in calcuations, including roundoff errors.
- */
- TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
- while (--words > 1) {
- TclEmitInstInt4(INST_REVERSE, 2, envPtr);
- TclEmitOpcode(INST_DIV, envPtr);
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * IndexTailVarIfKnown --
- *
- * Procedure used in compiling [global] and [variable] commands. It
- * inspects the variable name described by varTokenPtr and, if the tail
- * is known at compile time, defines a corresponding local variable.
- *
- * Results:
- * Returns the variable's index in the table of compiled locals if the
- * tail is known at compile time, or -1 otherwise.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-IndexTailVarIfKnown(
- Tcl_Interp *interp,
- Tcl_Token *varTokenPtr, /* Token representing the variable name */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Obj *tailPtr;
- const char *tailName, *p;
- int len, n = varTokenPtr->numComponents;
- Tcl_Token *lastTokenPtr;
- int full, localIndex;
-
- /*
- * Determine if the tail is (a) known at compile time, and (b) not an
- * array element. Should any of these fail, return an error so that
- * the non-compiled command will be called at runtime.
- * In order for the tail to be known at compile time, the last token
- * in the word has to be constant and contain "::" if it is not the
- * only one.
- */
-
- if (envPtr->procPtr == NULL) {
- return -1;
- }
-
- TclNewObj(tailPtr);
- if (TclWordKnownAtCompileTime(varTokenPtr, tailPtr)) {
- full = 1;
- lastTokenPtr = varTokenPtr;
- } else {
- full = 0;
- lastTokenPtr = varTokenPtr + n;
- if (!TclWordKnownAtCompileTime(lastTokenPtr, tailPtr)) {
- Tcl_DecrRefCount(tailPtr);
- return -1;
- }
- }
-
- tailName = TclGetStringFromObj(tailPtr, &len);
-
- if (len) {
- if (*(tailName+len-1) == ')') {
- /*
- * Possible array: bail out
- */
-
- Tcl_DecrRefCount(tailPtr);
- return -1;
- }
-
- /*
- * Get the tail: immediately after the last '::'
- */
-
- for(p = tailName + len -1; p > tailName; p--) {
- if ((*p == ':') && (*(p-1) == ':')) {
- p++;
- break;
- }
- }
- if (!full && (p == tailName)) {
- /*
- * No :: in the last component
- */
- Tcl_DecrRefCount(tailPtr);
- return -1;
- }
- len -= p - tailName;
- tailName = p;
- }
-
- localIndex = TclFindCompiledLocal(tailName, len,
- /*create*/ TCL_CREATE_VAR,
- envPtr->procPtr);
- Tcl_DecrRefCount(tailPtr);
- return localIndex;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileUpvarCmd --
- *
- * Procedure called to compile the "upvar" 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 "upvar" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileUpvarCmd(
- 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, *otherTokenPtr, *localTokenPtr;
- int localIndex, numWords, i;
- DefineLineInformation; /* TIP #280 */
- Tcl_Obj *objPtr;
-
- if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
- }
-
- numWords = parsePtr->numWords;
- if (numWords < 3) {
- return TCL_ERROR;
- }
-
- /*
- * Push the frame index if it is known at compile time
- */
-
- objPtr = Tcl_NewObj();
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- if(TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
- CallFrame *framePtr;
- Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr;
-
- /*
- * Attempt to convert to a level reference. Note that TclObjGetFrame
- * only changes the obj type when a conversion was successful.
- */
-
- TclObjGetFrame(interp, objPtr, &framePtr);
- newTypePtr = objPtr->typePtr;
- Tcl_DecrRefCount(objPtr);
-
- if (newTypePtr != typePtr) {
- if(numWords%2) {
- return TCL_ERROR;
- }
- /* TODO: Push the known value instead? */
- CompileWord(envPtr, tokenPtr, interp, 1);
- otherTokenPtr = TokenAfter(tokenPtr);
- i = 2;
- } else {
- if(!(numWords%2)) {
- return TCL_ERROR;
- }
- PushLiteral(envPtr, "1", 1);
- otherTokenPtr = tokenPtr;
- i = 1;
- }
- } else {
- Tcl_DecrRefCount(objPtr);
- return TCL_ERROR;
- }
-
- /*
- * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a
- * local variable, return an error so that the non-compiled command will
- * be called at runtime.
- */
-
- for(; i<numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) {
- localTokenPtr = TokenAfter(otherTokenPtr);
-
- CompileWord(envPtr, otherTokenPtr, interp, i);
- localIndex = LocalScalarFromToken(localTokenPtr, envPtr);
- if (localIndex < 0) {
- return TCL_ERROR;
- }
- TclEmitInstInt4(INST_UPVAR, localIndex, envPtr);
- }
-
- /*
- * Pop the frame index, and set the result to empty
- */
-
- TclEmitOpcode(INST_POP, envPtr);
- PushLiteral(envPtr, "", 0);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileNamespaceCmd --
- *
- * Procedure called to compile the "namespace" command; currently, only
- * the subcommand "namespace upvar" is compiled to bytecodes.
- *
- * 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 "namespace upvar"
- * command at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileNamespaceCmd(
- 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, *otherTokenPtr, *localTokenPtr;
- int localIndex, numWords, i;
- DefineLineInformation; /* TIP #280 */
-
- if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * Only compile [namespace upvar ...]: needs an odd number of args, >=5
- */
-
- numWords = parsePtr->numWords;
- if (!(numWords%2) || (numWords < 5)) {
- return TCL_ERROR;
- }
-
- /*
- * Check if the second argument is "upvar"
- */
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- if ((tokenPtr->size != 5) /* 5 == strlen("upvar") */
- || strncmp(tokenPtr->start, "upvar", 5)) {
- return TCL_ERROR;
- }
-
- /*
- * Push the namespace
- */
-
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 2);
-
- /*
- * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a
- * local variable, return an error so that the non-compiled command will
- * be called at runtime.
- */
-
- localTokenPtr = tokenPtr;
- for(i=3; i<numWords; i+=2) {
- otherTokenPtr = TokenAfter(localTokenPtr);
- localTokenPtr = TokenAfter(otherTokenPtr);
-
- CompileWord(envPtr, otherTokenPtr, interp, i);
- localIndex = LocalScalarFromToken(localTokenPtr, envPtr);
- if (localIndex < 0) {
- return TCL_ERROR;
- }
- TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr);
- }
-
- /*
- * Pop the namespace, and set the result to empty
- */
-
- TclEmitOpcode(INST_POP, envPtr);
- PushLiteral(envPtr, "", 0);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileGlobalCmd --
- *
- * Procedure called to compile the "global" 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 "global" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileGlobalCmd(
- 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 *varTokenPtr;
- int localIndex, numWords, i;
- DefineLineInformation; /* TIP #280 */
-
- numWords = parsePtr->numWords;
- if (numWords < 2) {
- return TCL_ERROR;
- }
-
- /*
- * 'global' has no effect outside of proc bodies; handle that at runtime
- */
-
- if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * Push the namespace
- */
-
- PushLiteral(envPtr, "::", 2);
-
- /*
- * Loop over the variables.
- */
-
- varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- for(i=1; i<numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) {
- localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
-
- if(localIndex < 0) {
- return TCL_ERROR;
- }
-
- /* TODO: Consider what values can pass through the
- * IndexTailVarIfKnown() screen. Full CompileWord()
- * likely does not apply here. Push known value instead. */
- CompileWord(envPtr, varTokenPtr, interp, i);
- TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr);
- }
-
- /*
- * Pop the namespace, and set the result to empty
- */
-
- TclEmitOpcode(INST_POP, envPtr);
- PushLiteral(envPtr, "", 0);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileVariableCmd --
- *
- * Procedure called to compile the "variable" 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 "variable" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileVariableCmd(
- 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 *varTokenPtr, *valueTokenPtr;
- int localIndex, numWords, i;
- DefineLineInformation; /* TIP #280 */
-
- numWords = parsePtr->numWords;
- if (numWords < 2) {
- return TCL_ERROR;
- }
-
- /*
- * Bail out if not compiling a proc body
- */
-
- if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * Loop over the (var, value) pairs.
- */
-
- valueTokenPtr = parsePtr->tokenPtr;
- for(i=1; i<numWords; i+=2) {
- varTokenPtr = TokenAfter(valueTokenPtr);
- valueTokenPtr = TokenAfter(varTokenPtr);
-
- localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
-
- if(localIndex < 0) {
- return TCL_ERROR;
- }
-
- /* TODO: Consider what values can pass through the
- * IndexTailVarIfKnown() screen. Full CompileWord()
- * likely does not apply here. Push known value instead. */
- CompileWord(envPtr, varTokenPtr, interp, i);
- TclEmitInstInt4(INST_VARIABLE, localIndex, envPtr);
-
- if (i != numWords-1) {
- /*
- * A value has been given: set the variable, pop the value
- */
-
- CompileWord(envPtr, valueTokenPtr, interp, i+1);
- TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
- TclEmitOpcode(INST_POP, envPtr);
- }
- }
-
- /*
- * Set the result to empty
- */
-
- PushLiteral(envPtr, "", 0);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileEnsemble --
- *
- * Procedure called to compile an ensemble command. Note that most
- * ensembles are not compiled, since modifying a compiled ensemble causes
- * a invalidation of all existing bytecode (expensive!) which is not
- * normally warranted.
- *
- * 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 subcommands of the
- * ensemble at runtime if a compile-time mapping is possible.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileEnsemble(
- 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;
- Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
- Tcl_Command ensemble = (Tcl_Command) cmdPtr;
- Tcl_Parse synthetic;
- int len, numBytes, result, flags = 0, i;
- const char *word;
- DefineLineInformation;
-
- if (parsePtr->numWords < 2) {
- return TCL_ERROR;
- }
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- /*
- * Too hard.
- */
-
- return TCL_ERROR;
- }
-
- word = tokenPtr[1].start;
- numBytes = tokenPtr[1].size;
-
- /*
- * There's a sporting chance we'll be able to compile this. But now we
- * must check properly. To do that, check that we're compiling an ensemble
- * that has a compilable command as its appropriate subcommand.
- */
-
- if (Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj) != TCL_OK
- || mapObj == NULL) {
- /*
- * Either not an ensemble or a mapping isn't installed. Crud. Too hard
- * to proceed.
- */
-
- return TCL_ERROR;
- }
-
- /*
- * Next, get the flags. We need them on several code paths.
- */
-
- (void) Tcl_GetEnsembleFlags(NULL, ensemble, &flags);
-
- /*
- * Check to see if there's also a subcommand list; must check to see if
- * the subcommand we are calling is in that list if it exists, since that
- * list filters the entries in the map.
- */
-
- (void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj);
- if (listObj != NULL) {
- int sclen;
- const char *str;
- Tcl_Obj *matchObj = NULL;
-
- if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) {
- return TCL_ERROR;
- }
- for (i=0 ; i<len ; i++) {
- str = Tcl_GetStringFromObj(elems[i], &sclen);
- if (sclen==numBytes && !memcmp(word, str, (unsigned) numBytes)) {
- /*
- * Exact match! Excellent!
- */
-
- result = Tcl_DictObjGet(NULL, mapObj,elems[i], &targetCmdObj);
- if (result != TCL_OK || targetCmdObj == NULL) {
- return TCL_ERROR;
- }
- goto doneMapLookup;
- }
-
- /*
- * Check to see if we've got a prefix match. A single prefix match
- * is fine, and allows us to refine our dictionary lookup, but
- * multiple prefix matches is a Bad Thing and will prevent us from
- * making progress. Note that we cannot do the lookup immediately
- * in the prefix case; might be another entry later in the list
- * that causes things to fail.
- */
-
- if ((flags & TCL_ENSEMBLE_PREFIX)
- && strncmp(word, str, (unsigned) numBytes) == 0) {
- if (matchObj != NULL) {
- return TCL_ERROR;
- }
- matchObj = elems[i];
- }
- }
- if (matchObj != NULL) {
- result = Tcl_DictObjGet(NULL, mapObj, matchObj, &targetCmdObj);
- if (result != TCL_OK || targetCmdObj == NULL) {
- return TCL_ERROR;
- }
- goto doneMapLookup;
- }
- return TCL_ERROR;
- } else {
- /*
- * No map, so check the dictionary directly.
- */
-
- TclNewStringObj(subcmdObj, word, numBytes);
- result = Tcl_DictObjGet(NULL, mapObj, subcmdObj, &targetCmdObj);
- TclDecrRefCount(subcmdObj);
- if (result == TCL_OK && targetCmdObj != NULL) {
- /*
- * Got it. Skip the fiddling around with prefixes.
- */
-
- goto doneMapLookup;
- }
-
- /*
- * We've not literally got a valid subcommand. But maybe we have a
- * prefix. Check if prefix matches are allowed.
- */
-
- if (flags & TCL_ENSEMBLE_PREFIX) {
- Tcl_DictSearch s;
- int done, matched;
- Tcl_Obj *tmpObj;
-
- /*
- * Iterate over the keys in the dictionary, checking to see if
- * we're a prefix.
- */
-
- Tcl_DictObjFirst(NULL,mapObj,&s,&subcmdObj,&tmpObj,&done);
- matched = 0;
- while (!done) {
- if (strncmp(TclGetString(subcmdObj), word,
- (unsigned) numBytes) == 0) {
- if (matched++) {
- /*
- * Must have matched twice! Not unique, so no point
- * looking further.
- */
-
- break;
- }
- targetCmdObj = tmpObj;
- }
- Tcl_DictObjNext(&s, &subcmdObj, &tmpObj, &done);
- }
- Tcl_DictObjDone(&s);
-
- /*
- * If we have anything other than a single match, we've failed the
- * unique prefix check.
- */
-
- if (matched != 1) {
- return TCL_ERROR;
- }
- } else {
- return TCL_ERROR;
- }
- }
-
- /*
- * OK, we definitely map to something. But what?
- *
- * The command we map to is the first word out of the map element. Note
- * that we also reject dealing with multi-element rewrites if we are in a
- * safe interpreter, as there is otherwise a (highly gnarly!) way to make
- * Tcl crash open to exploit.
- */
-
- doneMapLookup:
- if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) {
- return TCL_ERROR;
- }
- if (len > 1 && Tcl_IsSafe(interp)) {
- return TCL_ERROR;
- }
- targetCmdObj = elems[0];
-
- Tcl_IncrRefCount(targetCmdObj);
- cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj);
- TclDecrRefCount(targetCmdObj);
- if (cmdPtr == NULL || cmdPtr->compileProc == NULL
- || cmdPtr->flags & CMD_HAS_EXEC_TRACES
- || ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) {
- /*
- * Maps to an undefined command or a command without a compiler.
- * Cannot compile.
- */
-
- return TCL_ERROR;
- }
-
- /*
- * Now we've done the mapping process, can now actually try to compile.
- * We do this by handing off to the subcommand's actual compiler. But to
- * do that, we have to perform some trickery to rewrite the arguments.
- */
-
- TclParseInit(interp, NULL, 0, &synthetic);
- synthetic.numWords = parsePtr->numWords - 2 + len;
- TclGrowParseTokenArray(&synthetic, 2*len);
- synthetic.numTokens = 2*len;
-
- /*
- * Now we have the space to work in, install something rewritten. Note
- * that we are here praying for all our might that none of these words are
- * a script; the error detection code will crash if that happens and there
- * is nothing we can do to avoid it!
- */
-
- for (i=0 ; i<len ; i++) {
- int sclen;
- const char *str = Tcl_GetStringFromObj(elems[i], &sclen);
-
- synthetic.tokenPtr[2*i].type = TCL_TOKEN_SIMPLE_WORD;
- synthetic.tokenPtr[2*i].start = str;
- synthetic.tokenPtr[2*i].size = sclen;
- synthetic.tokenPtr[2*i].numComponents = 1;
-
- synthetic.tokenPtr[2*i+1].type = TCL_TOKEN_TEXT;
- synthetic.tokenPtr[2*i+1].start = str;
- synthetic.tokenPtr[2*i+1].size = sclen;
- synthetic.tokenPtr[2*i+1].numComponents = 0;
- }
-
- /*
- * Copy over the real argument tokens.
- */
-
- for (i=len; i<synthetic.numWords; i++) {
- int toCopy;
- tokenPtr = TokenAfter(tokenPtr);
- toCopy = tokenPtr->numComponents + 1;
- TclGrowParseTokenArray(&synthetic, toCopy);
- memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr,
- sizeof(Tcl_Token) * toCopy);
- synthetic.numTokens += toCopy;
- }
-
- /*
- * Hand off compilation to the subcommand compiler. At last!
- */
-
- mapPtr->loc[eclIndex].line++;
- mapPtr->loc[eclIndex].next++;
-
- result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr);
-
- mapPtr->loc[eclIndex].line--;
- mapPtr->loc[eclIndex].next--;
-
- /*
- * Clean up if necessary.
- */
-
- Tcl_FreeParse(&synthetic);
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileInfoExistsCmd --
- *
- * Procedure called to compile the "info exists" subcommand.
- *
- * 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.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileInfoExistsCmd(
- 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;
- int isScalar, simpleVarName, localIndex;
- DefineLineInformation; /* TIP #280 */
-
- if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- }
-
- /*
- * Decide if we can use a frame slot for the var/array name or if we need
- * to emit code to compute and push the name at runtime. We use a frame
- * slot (entry in the array of local vars) if we are compiling a procedure
- * body and if the name is simple text that does not include namespace
- * qualifiers.
- */
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarNameWord(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex,
- &simpleVarName, &isScalar, 1);
-
- /*
- * Emit instruction to check the variable for existence.
- */
-
- if (simpleVarName) {
- if (isScalar) {
- if (localIndex < 0) {
- TclEmitOpcode(INST_EXIST_STK, envPtr);
- } else {
- TclEmitInstInt4(INST_EXIST_SCALAR, localIndex, envPtr);
- }
- } else {
- if (localIndex < 0) {
- TclEmitOpcode(INST_EXIST_ARRAY_STK, envPtr);
- } else {
- TclEmitInstInt4(INST_EXIST_ARRAY, localIndex, envPtr);
- }
- }
- } else {
- TclEmitOpcode(INST_EXIST_STK, envPtr);
- }
-
- return TCL_OK;
}
/*