summaryrefslogtreecommitdiffstats
path: root/generic/tclCompCmds.c
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2010-02-26 14:38:35 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2010-02-26 14:38:35 (GMT)
commit42d4d24dbd5e820e6f3e0d50b3a619ee6dc0f8d7 (patch)
treea8d7630b12ddf60ab8264a7f04d71dd92b8b7874 /generic/tclCompCmds.c
parent43489532dea0636fb88a85b2b5fa8097b27166da (diff)
downloadtcl-42d4d24dbd5e820e6f3e0d50b3a619ee6dc0f8d7.zip
tcl-42d4d24dbd5e820e6f3e0d50b3a619ee6dc0f8d7.tar.gz
tcl-42d4d24dbd5e820e6f3e0d50b3a619ee6dc0f8d7.tar.bz2
Split tclCompCmds.c into two pieces to improve developer sanity.
Diffstat (limited to 'generic/tclCompCmds.c')
-rw-r--r--generic/tclCompCmds.c3916
1 files changed, 375 insertions, 3541 deletions
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 280ab5e..3a564ff 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompCmds.c,v 1.166 2010/02/25 10:56:16 dkf Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.167 2010/02/26 14:38:36 dkf Exp $
*/
#include "tclInt.h"
@@ -32,54 +32,16 @@ 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,
- Tcl_Obj *appendObj, ByteCode *codePtr,
- unsigned int pcOffset);
+static void CompileReturnInternal(CompileEnv *envPtr,
+ unsigned char op, int code, int level,
+ Tcl_Obj *returnOpts);
+static int IndexTailVarIfKnown(Tcl_Interp *interp,
+ Tcl_Token *varTokenPtr, 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);
-static void IssueSwitchChainedTests(Tcl_Interp *interp,
- CompileEnv *envPtr, ExtCmdLoc *mapPtr,
- int eclIndex, int mode, int noCase,
- int valueIndex, Tcl_Token *valueTokenPtr,
- int numWords, Tcl_Token **bodyToken,
- int *bodyLines, int **bodyNext);
-static void IssueSwitchJumpTable(Tcl_Interp *interp,
- CompileEnv *envPtr, ExtCmdLoc *mapPtr,
- int eclIndex, int valueIndex,
- Tcl_Token *valueTokenPtr, int numWords,
- Tcl_Token **bodyToken, int *bodyLines,
- int **bodyContLines);
-static int IssueTryFinallyInstructions(Tcl_Interp *interp,
- CompileEnv *envPtr, Tcl_Token *bodyToken,
- int numHandlers, int *matchCodes,
- Tcl_Obj **matchClauses, int *resultVarIndices,
- int *optionVarIndices, Tcl_Token **handlerTokens,
- Tcl_Token *finallyToken);
-static int IssueTryInstructions(Tcl_Interp *interp,
- CompileEnv *envPtr, Tcl_Token *bodyToken,
- int numHandlers, int *matchCodes,
- Tcl_Obj **matchClauses, int *resultVarIndices,
- int *optionVarIndices, Tcl_Token **handlerTokens);
/*
* Macro that encapsulates an efficiency trick that avoids a function call for
@@ -139,13 +101,6 @@ const AuxDataType tclForeachInfoType = {
PrintForeachInfo /* printProc */
};
-const AuxDataType tclJumptableInfoType = {
- "JumptableInfo", /* name */
- DupJumptableInfo, /* dupProc */
- FreeJumptableInfo, /* freeProc */
- PrintJumptableInfo /* printProc */
-};
-
const AuxDataType tclDictUpdateInfoType = {
"DictUpdateInfo", /* name */
DupDictUpdateInfo, /* dupProc */
@@ -2026,6 +1981,81 @@ PrintForeachInfo(
/*
*----------------------------------------------------------------------
*
+ * 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=2; i<=numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) {
+ localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
+
+ if (localIndex < 0) {
+ return TCL_ERROR;
+ }
+
+ CompileWord(envPtr, varTokenPtr, interp, 1);
+ TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr);
+ }
+
+ /*
+ * Pop the namespace, and set the result to empty
+ */
+
+ TclEmitOpcode(INST_POP, envPtr);
+ PushLiteral(envPtr, "", 0);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompileIfCmd --
*
* Procedure called to compile the "if" command.
@@ -2462,6 +2492,78 @@ TclCompileIncrCmd(
/*
*----------------------------------------------------------------------
*
+ * 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, 0, &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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompileLappendCmd --
*
* Procedure called to compile the "lappend" command.
@@ -3066,6 +3168,98 @@ TclCompileLsetCmd(
/*
*----------------------------------------------------------------------
*
+ * 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 simpleVarName, isScalar, 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, 1);
+
+ /*
+ * 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=4; i<=numWords; i+=2) {
+ otherTokenPtr = TokenAfter(localTokenPtr);
+ localTokenPtr = TokenAfter(otherTokenPtr);
+
+ CompileWord(envPtr, otherTokenPtr, interp, 1);
+ PushVarNameWord(interp, localTokenPtr, envPtr, 0,
+ &localIndex, &simpleVarName, &isScalar, 1);
+
+ if ((localIndex < 0) || !isScalar) {
+ 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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompileRegexpCmd --
*
* Procedure called to compile the "regexp" command.
@@ -3425,224 +3619,23 @@ TclCompileSyntaxError(
/*
*----------------------------------------------------------------------
*
- * TclCompileSetCmd --
+ * TclCompileUpvarCmd --
*
- * Procedure called to compile the "set" command.
+ * 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 "set" command at
+ * Instructions are added to envPtr to execute the "upvar" 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, 0,
- &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.
- */
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 1);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 2);
- TclEmitOpcode(INST_STR_EQ, envPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileStringIndexCmd --
- *
- * Procedure called to compile the simplest and most common form of the
- * "string index" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "string index" command
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileStringIndexCmd(
+TclCompileUpvarCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
@@ -3650,1434 +3643,108 @@ TclCompileStringIndexCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
+ Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
+ int simpleVarName, isScalar, localIndex, numWords, i;
DefineLineInformation; /* TIP #280 */
- Tcl_Token *tokenPtr;
+ Tcl_Obj *objPtr = Tcl_NewObj();
- if (parsePtr->numWords != 3) {
+ if (envPtr->procPtr == NULL) {
+ Tcl_DecrRefCount(objPtr);
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) {
+ numWords = parsePtr->numWords;
+ if (numWords < 3) {
+ Tcl_DecrRefCount(objPtr);
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);
- }
/*
- * Push the matcher.
+ * Push the frame index if it is known at compile time
*/
- 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;
- Tcl_Obj *objPtr;
-
- if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- }
-
tokenPtr = TokenAfter(parsePtr->tokenPtr);
- TclNewObj(objPtr);
if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
- /*
- * Here someone is asking for the length of a static string (or
- * something with backslashes). Just push the actual character (not
- * byte) length.
- */
-
- char buf[TCL_INTEGER_SPACE];
- int len = Tcl_GetCharLength(objPtr);
-
- len = sprintf(buf, "%d", len);
- PushLiteral(envPtr, buf, len);
- } else {
- SetLineInformation(1);
- CompileTokens(envPtr, tokenPtr, interp);
- TclEmitOpcode(INST_STR_LEN, envPtr);
- }
- TclDecrRefCount(objPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileSubstCmd --
- *
- * Procedure called to compile the "subst" 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 "subst" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileSubstCmd(
- 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 numArgs = parsePtr->numWords - 1;
- int numOpts = numArgs - 1;
- int objc, flags = TCL_SUBST_ALL;
- Tcl_Obj **objv/*, *toSubst = NULL*/;
- Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
- int code = TCL_ERROR;
- DefineLineInformation; /* TIP #280 */
-
- if (numArgs == 0) {
- return TCL_ERROR;
- }
-
- objv = TclStackAlloc(interp, /*numArgs*/ numOpts * sizeof(Tcl_Obj *));
-
- for (objc = 0; objc < /*numArgs*/ numOpts; objc++) {
- objv[objc] = Tcl_NewObj();
- Tcl_IncrRefCount(objv[objc]);
- if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
- objc++;
- goto cleanup;
- }
- wordTokenPtr = TokenAfter(wordTokenPtr);
- }
-
-/*
- if (TclSubstOptions(NULL, numOpts, objv, &flags) == TCL_OK) {
- toSubst = objv[numOpts];
- Tcl_IncrRefCount(toSubst);
- }
-*/
-
- /* TODO: Figure out expansion to cover WordKnownAtCompileTime
- * The difficulty is that WKACT makes a copy, and if TclSubstParse
- * below parses the copy of the original source string, some deep
- * parts of the compile machinery get upset. They want all pointers
- * stored in Tcl_Tokens to point back to the same original string.
- */
- if (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- code = TclSubstOptions(NULL, numOpts, objv, &flags);
- }
-
- cleanup:
- while (--objc >= 0) {
- TclDecrRefCount(objv[objc]);
- }
- TclStackFree(interp, objv);
- if (/*toSubst == NULL*/ code != TCL_OK) {
- return TCL_ERROR;
- }
-
- SetLineInformation(numArgs);
- TclSubstCompile(interp, wordTokenPtr[1].start, wordTokenPtr[1].size,
- flags, mapPtr->loc[eclIndex].line[numArgs], envPtr);
-
-/* TclDecrRefCount(toSubst);*/
- return TCL_OK;
-}
-
-void
-TclSubstCompile(
- Tcl_Interp *interp,
- const char *bytes,
- int numBytes,
- int flags,
- int line,
- CompileEnv *envPtr)
-{
- Tcl_Token *endTokenPtr, *tokenPtr;
- int breakOffset = 0, count = 0, bline = line;
- Tcl_Parse parse;
- Tcl_InterpState state = NULL;
-
- TclSubstParse(interp, bytes, numBytes, flags, &parse, &state);
-
- for (tokenPtr = parse.tokenPtr, endTokenPtr = tokenPtr + parse.numTokens;
- tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) {
- int length, literal, catchRange, breakJump;
- char buf[TCL_UTF_MAX];
- JumpFixup startFixup, okFixup, returnFixup, breakFixup;
- JumpFixup continueFixup, otherFixup, endFixup;
-
- switch (tokenPtr->type) {
- case TCL_TOKEN_TEXT:
- literal = TclRegisterNewLiteral(envPtr,
- tokenPtr->start, tokenPtr->size);
- TclEmitPush(literal, envPtr);
- TclAdvanceLines(&bline, tokenPtr->start,
- tokenPtr->start + tokenPtr->size);
- count++;
- continue;
- case TCL_TOKEN_BS:
- length = Tcl_UtfBackslash(tokenPtr->start, NULL, buf);
- literal = TclRegisterNewLiteral(envPtr, buf, length);
- TclEmitPush(literal, envPtr);
- count++;
- continue;
- }
-
- while (count > 255) {
- TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
- count -= 254;
- }
- if (count > 1) {
- TclEmitInstInt1(INST_CONCAT1, count, envPtr);
- count = 1;
- }
-
- if (breakOffset == 0) {
- /* Jump to the start (jump over the jump to end) */
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &startFixup);
-
- /* Jump to the end (all BREAKs land here) */
- breakOffset = CurrentOffset(envPtr);
- TclEmitInstInt4(INST_JUMP4, 0, envPtr);
-
- /* Start */
- if (TclFixupForwardJumpToHere(envPtr, &startFixup, 127)) {
- Tcl_Panic("TclCompileSubstCmd: bad start jump distance %d",
- CurrentOffset(envPtr) - startFixup.codeOffset);
- }
- }
-
- envPtr->line = bline;
- catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
- TclEmitInstInt4(INST_BEGIN_CATCH4, catchRange, envPtr);
- ExceptionRangeStarts(envPtr, catchRange);
-
- switch (tokenPtr->type) {
- case TCL_TOKEN_COMMAND:
- TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2,
- envPtr);
- count++;
- break;
- case TCL_TOKEN_VARIABLE:
- TclCompileVarSubst(interp, tokenPtr, envPtr);
- count++;
- break;
- default:
- Tcl_Panic("unexpected token type in TclCompileSubstCmd: %d",
- tokenPtr->type);
- }
-
- ExceptionRangeEnds(envPtr, catchRange);
-
- /* Substitution produced TCL_OK */
- TclEmitOpcode(INST_END_CATCH, envPtr);
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &okFixup);
-
- /* Exceptional return codes processed here */
- ExceptionRangeTarget(envPtr, catchRange, catchOffset);
- TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr);
- TclEmitOpcode(INST_PUSH_RESULT, envPtr);
- TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
- TclEmitOpcode(INST_END_CATCH, envPtr);
- TclEmitOpcode(INST_RETURN_CODE_BRANCH, envPtr);
-
- /* ERROR -> reraise it */
- TclEmitOpcode(INST_RETURN_STK, envPtr);
- TclEmitOpcode(INST_NOP, envPtr);
-
- /* RETURN */
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &returnFixup);
-
- /* BREAK */
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &breakFixup);
-
- /* CONTINUE */
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &continueFixup);
-
- /* OTHER */
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &otherFixup);
-
- /* BREAK destination */
- if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) {
- Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d",
- CurrentOffset(envPtr) - breakFixup.codeOffset);
- }
- TclEmitOpcode(INST_POP, envPtr);
- TclEmitOpcode(INST_POP, envPtr);
-
- breakJump = CurrentOffset(envPtr) - breakOffset;
- if (breakJump > 127) {
- TclEmitInstInt4(INST_JUMP4, -breakJump, envPtr);
- } else {
- TclEmitInstInt1(INST_JUMP1, -breakJump, envPtr);
- }
-
- /* CONTINUE destination */
- if (TclFixupForwardJumpToHere(envPtr, &continueFixup, 127)) {
- Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d",
- CurrentOffset(envPtr) - continueFixup.codeOffset);
- }
- TclEmitOpcode(INST_POP, envPtr);
- TclEmitOpcode(INST_POP, envPtr);
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup);
-
- /* RETURN + other destination */
- if (TclFixupForwardJumpToHere(envPtr, &returnFixup, 127)) {
- Tcl_Panic("TclCompileSubstCmd: bad return jump distance %d",
- CurrentOffset(envPtr) - returnFixup.codeOffset);
- }
- if (TclFixupForwardJumpToHere(envPtr, &otherFixup, 127)) {
- Tcl_Panic("TclCompileSubstCmd: bad other jump distance %d",
- CurrentOffset(envPtr) - otherFixup.codeOffset);
- }
- /* Pull the result to top of stack, discard options dict */
- TclEmitInstInt4(INST_REVERSE, 2, envPtr);
- TclEmitOpcode(INST_POP, envPtr);
-
- /*
- * We've emitted several POP instructions, and the automatic
- * computations for stack depth requirements have been decrementing
- * for every one. However, we know that every branch actually taken
- * only encounters some of those instructions. No branch passes
- * through them all. So, we now have a stack requirements estimate
- * that is too low. Here we manually fix that up.
- */
- TclAdjustStackDepth(5, envPtr);
-
- /* OK destination */
- if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) {
- Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %d",
- CurrentOffset(envPtr) - okFixup.codeOffset);
- }
- if (count > 1) {
- TclEmitInstInt1(INST_CONCAT1, count, envPtr);
- count = 1;
- }
-
- /* CONTINUE jump to here */
- if (TclFixupForwardJumpToHere(envPtr, &endFixup, 127)) {
- Tcl_Panic("TclCompileSubstCmd: bad end jump distance %d",
- CurrentOffset(envPtr) - endFixup.codeOffset);
- }
- bline = envPtr->line;
- }
-
-
- while (count > 255) {
- TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
- count -= 254;
- }
- if (count > 1) {
- TclEmitInstInt1(INST_CONCAT1, count, envPtr);
- }
-
- Tcl_FreeParse(&parse);
-
- if (state != NULL) {
- Tcl_RestoreInterpState(interp, state);
- TclCompileSyntaxError(interp, envPtr);
- }
-
- /* Final target of the multi-jump from all BREAKs */
- if (breakOffset > 0) {
- TclUpdateInstInt4AtPc(INST_JUMP4, CurrentOffset(envPtr) - breakOffset,
- envPtr->codeStart + breakOffset);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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 **bodyContLines; /* Array of continuation line info. */
- int noCase; /* Has the -nocase flag been given? */
- int foundMode = 0; /* Have we seen a mode flag yet? */
- int isListedArms = 0;
- int i, valueIndex;
- int result = TCL_ERROR;
- 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.
- *
- * 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).
- */
-
- for (; numWords>=3 ; tokenPtr=TokenAfter(tokenPtr),numWords--) {
- register unsigned size = tokenPtr[1].size;
- register const char *chrs = tokenPtr[1].start;
+ CallFrame *framePtr;
+ const Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr;
/*
- * 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).
+ * Attempt to convert to a level reference. Note that TclObjGetFrame
+ * only changes the obj type when a conversion was successful.
*/
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || size < 2) {
- return TCL_ERROR;
- }
+ TclObjGetFrame(interp, objPtr, &framePtr);
+ newTypePtr = objPtr->typePtr;
+ Tcl_DecrRefCount(objPtr);
- 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) {
+ if (newTypePtr != typePtr) {
+ if (numWords%2) {
return TCL_ERROR;
}
- mode = Switch_Glob;
- foundMode = 1;
- valueIndex++;
- continue;
- } else if ((size <= 7) && !memcmp(chrs, "-regexp", size)) {
- if (foundMode) {
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ otherTokenPtr = TokenAfter(tokenPtr);
+ i = 4;
+ } else {
+ if (!(numWords%2)) {
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;
+ PushLiteral(envPtr, "1", 1);
+ otherTokenPtr = tokenPtr;
+ i = 3;
}
-
- /*
- * 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!
- */
-
+ } else {
+ Tcl_DecrRefCount(objPtr);
return TCL_ERROR;
}
/*
- * 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. */
- tokenPtr = TokenAfter(tokenPtr);
- numWords--;
-
- /*
- * 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.
+ * 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.
*/
- if (numWords == 1) {
- Tcl_DString bodyList;
- const char **argv = NULL, *tokenStartPtr, *p;
- 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. */
- int isTokenBraced;
-
- /*
- * Test that we've got a suitable body list as a simple (i.e. braced)
- * word, and that the elements of the body are simple words too. This
- * is really rather nasty indeed.
- */
-
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
-
- Tcl_DStringInit(&bodyList);
- Tcl_DStringAppend(&bodyList, tokenPtr[1].start, tokenPtr[1].size);
- if (Tcl_SplitList(NULL, Tcl_DStringValue(&bodyList), &numWords,
- &argv) != TCL_OK) {
- Tcl_DStringFree(&bodyList);
- return TCL_ERROR;
- }
- Tcl_DStringFree(&bodyList);
+ for (; i<=numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) {
+ localTokenPtr = TokenAfter(otherTokenPtr);
- /*
- * Now we know what the switch arms are, we've got to see whether we
- * can synthesize tokens for the arms. First check whether we've got a
- * valid number of arms since we can do that now.
- */
+ CompileWord(envPtr, otherTokenPtr, interp, 1);
+ PushVarNameWord(interp, localTokenPtr, envPtr, 0,
+ &localIndex, &simpleVarName, &isScalar, 1);
- if (numWords == 0 || numWords % 2) {
- ckfree((char *) argv);
+ if ((localIndex < 0) || !isScalar) {
return TCL_ERROR;
}
-
- isListedArms = 1;
- bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * numWords);
- bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords);
- bodyLines = (int *) ckalloc(sizeof(int) * numWords);
- bodyContLines = (int **) ckalloc(sizeof(int*) * numWords);
-
- /*
- * Locate the start of the arms within the overall word.
- */
-
- bline = mapPtr->loc[eclIndex].line[valueIndex+1];
- p = tokenStartPtr = tokenPtr[1].start;
- while (isspace(UCHAR(*tokenStartPtr))) {
- tokenStartPtr++;
- }
- if (*tokenStartPtr == '{') {
- tokenStartPtr++;
- isTokenBraced = 1;
- } else {
- isTokenBraced = 0;
- }
-
- /*
- * TIP #280: Count lines within the literal list.
- */
-
- for (i=0 ; i<numWords ; i++) {
- bodyTokenArray[i].type = TCL_TOKEN_TEXT;
- bodyTokenArray[i].start = tokenStartPtr;
- bodyTokenArray[i].size = strlen(argv[i]);
- bodyTokenArray[i].numComponents = 0;
- bodyToken[i] = bodyTokenArray+i;
- tokenStartPtr += bodyTokenArray[i].size;
-
- /*
- * Test to see if we have guessed the end of the word correctly;
- * if not, we can't feed the real string to the sub-compilation
- * engine, and we're then stuck and so have to punt out to doing
- * everything at runtime.
- */
-
- if ((isTokenBraced && *(tokenStartPtr++) != '}') ||
- (tokenStartPtr < tokenPtr[1].start+tokenPtr[1].size
- && !isspace(UCHAR(*tokenStartPtr)))) {
- ckfree((char *) argv);
- goto freeTemporaries;
- }
-
- /*
- * 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, p, bodyTokenArray[i].start);
- TclAdvanceContinuations(&bline, &clNext,
- bodyTokenArray[i].start - envPtr->source);
- bodyLines[i] = bline;
- bodyContLines[i] = clNext;
- p = bodyTokenArray[i].start;
-
- while (isspace(UCHAR(*tokenStartPtr))) {
- tokenStartPtr++;
- if (tokenStartPtr >= tokenPtr[1].start+tokenPtr[1].size) {
- break;
- }
- }
- if (*tokenStartPtr == '{') {
- tokenStartPtr++;
- isTokenBraced = 1;
- } else {
- isTokenBraced = 0;
- }
- }
- ckfree((char *) argv);
-
- /*
- * Check that we've parsed everything we thought we were going to
- * parse. If not, something odd is going on (I believe it is possible
- * to defeat the code above) and we should bail out.
- */
-
- if (tokenStartPtr != tokenPtr[1].start+tokenPtr[1].size) {
- goto freeTemporaries;
- }
-
- } 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);
- bodyContLines = (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 ||
- tokenPtr->numComponents != 1) {
- goto freeTemporaries;
- }
- bodyToken[i] = tokenPtr+1;
-
- /*
- * TIP #280: Copy line information from regular cmd info.
- */
-
- bodyLines[i] = mapPtr->loc[eclIndex].line[valueIndex+1+i];
- bodyContLines[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).
- */
-
- if (bodyToken[numWords-1]->size == 1 &&
- bodyToken[numWords-1]->start[0] == '-') {
- goto freeTemporaries;
- }
-
- /*
- * Now we commit to generating code; the parsing stage per se is done.
- * 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.
- */
-
- if ((isListedArms) && (mode == Switch_Exact) && (!noCase)) {
- IssueSwitchJumpTable(interp, envPtr, mapPtr, eclIndex, valueIndex,
- valueTokenPtr, numWords, bodyToken, bodyLines, bodyContLines);
- } else {
- IssueSwitchChainedTests(interp, envPtr, mapPtr, eclIndex, mode,noCase,
- valueIndex, valueTokenPtr, numWords, bodyToken, bodyLines,
- bodyContLines);
- }
- result = TCL_OK;
-
- /*
- * Clean up all our temporary space and return.
- */
-
- freeTemporaries:
- ckfree((char *) bodyToken);
- ckfree((char *) bodyLines);
- ckfree((char *) bodyContLines);
- if (bodyTokenArray != NULL) {
- ckfree((char *) bodyTokenArray);
- }
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * IssueSwitchChainedTests --
- *
- * Generate instructions for a [switch] command that is to be compiled
- * into a sequence of tests. This is the generic handle-everything mode
- * that inherently has performance that is (on average) linear in the
- * number of tests. It is the only mode that can handle -glob and -regexp
- * matches, or anything that is case-insensitive. It does not handle the
- * wild-and-wooly end of regexp matching (i.e., capture of match results)
- * so that's when we spill to the interpreted version.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-IssueSwitchChainedTests(
- Tcl_Interp *interp, /* Context for compiling script bodies. */
- CompileEnv *envPtr, /* Holds resulting instructions. */
- ExtCmdLoc *mapPtr, /* For mapping tokens to their source code
- * location. */
- int eclIndex,
- int mode, /* Exact, Glob or Regexp */
- int noCase, /* Case-insensitivity flag. */
- int valueIndex, /* The value to match against. */
- Tcl_Token *valueTokenPtr,
- int numBodyTokens, /* Number of tokens describing things the
- * switch can match against and bodies to
- * execute when the match succeeds. */
- Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */
- int *bodyLines, /* Array of line numbers for body list
- * items. */
- int **bodyContLines) /* Array of continuation line info. */
-{
- enum {Switch_Exact, Switch_Glob, Switch_Regexp};
- int savedStackDepth = envPtr->currStackDepth;
- 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 nextArmFixupIndex;
- int simple, exact; /* For extracting the type of regexp. */
- int i;
-
- /*
- * First, we push the value we're matching against on the stack.
- */
-
- SetLineInformation(valueIndex);
- CompileTokens(envPtr, valueTokenPtr, interp);
-
- /*
- * Generate a test for each arm.
- */
-
- contFixIndex = -1;
- contFixCount = 0;
- fixupArray = TclStackAlloc(interp, sizeof(JumpFixup) * numBodyTokens);
- fixupTargetArray = TclStackAlloc(interp, sizeof(int) * numBodyTokens);
- memset(fixupTargetArray, 0, numBodyTokens * sizeof(int));
- fixupCount = 0;
- foundDefault = 0;
- for (i=0 ; i<numBodyTokens ; i+=2) {
- nextArmFixupIndex = -1;
- envPtr->currStackDepth = savedStackDepth + 1;
- if (i!=numBodyTokens-2 || bodyToken[numBodyTokens-2]->size != 7 ||
- memcmp(bodyToken[numBodyTokens-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:
- simple = 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) {
- /*
- * 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);
- } else if (exact && !noCase) {
- TclEmitOpcode(INST_STR_EQ, envPtr);
- } else {
- TclEmitInstInt1(INST_STR_MATCH, noCase, 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;
- }
-
- /*
- * Now do the actual compilation. Note that we do not use CompileBody
- * because we may have synthesized the tokens in a non-standard
- * pattern.
- */
-
- TclEmitOpcode(INST_POP, envPtr);
- envPtr->currStackDepth = savedStackDepth + 1;
- envPtr->line = bodyLines[i+1]; /* TIP #280 */
- envPtr->clNext = bodyContLines[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);
- }
- }
-
- /*
- * 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;
- }
- }
- }
- }
- TclStackFree(interp, fixupTargetArray);
- TclStackFree(interp, fixupArray);
-
- envPtr->currStackDepth = savedStackDepth + 1;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * IssueSwitchJumpTable --
- *
- * Generate instructions for a [switch] command that is to be compiled
- * into a jump table. This only handles the case where case-sensitive,
- * exact matching is used, but this is actually the most common case in
- * real code.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-IssueSwitchJumpTable(
- Tcl_Interp *interp, /* Context for compiling script bodies. */
- CompileEnv *envPtr, /* Holds resulting instructions. */
- ExtCmdLoc *mapPtr, /* For mapping tokens to their source code
- * location. */
- int eclIndex,
- int valueIndex, /* The value to match against. */
- Tcl_Token *valueTokenPtr,
- int numBodyTokens, /* Number of tokens describing things the
- * switch can match against and bodies to
- * execute when the match succeeds. */
- Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */
- int *bodyLines, /* Array of line numbers for body list
- * items. */
- int **bodyContLines) /* Array of continuation line info. */
-{
- JumptableInfo *jtPtr;
- int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation;
- int mustGenerate, foundDefault, jumpToDefault, i;
- Tcl_DString buffer;
- Tcl_HashEntry *hPtr;
-
- /*
- * First, we push the value we're matching against on the stack.
- */
-
- SetLineInformation(valueIndex);
- CompileTokens(envPtr, valueTokenPtr, interp);
-
- /*
- * 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 = TclStackAlloc(interp, sizeof(int) * (numBodyTokens/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<numBodyTokens ; i+=2) {
- /*
- * For each arm, we must first work out what to do with the match
- * term.
- */
-
- if (i!=numBodyTokens-2 || bodyToken[numBodyTokens-2]->size != 7 ||
- memcmp(bodyToken[numBodyTokens-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.
- */
-
- 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, CurrentOffset(envPtr) - jumpLocation);
- }
- 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 = bodyContLines[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 < numBodyTokens || !foundDefault) {
- finalFixups[numRealBodies++] = CurrentOffset(envPtr);
-
- /*
- * Easier by far to issue this jump as a fixed-width jump, since
- * otherwise we'd need to do a lot more (and more awkward)
- * rewriting when we fixed this all up.
- */
-
- TclEmitInstInt4(INST_JUMP4, 0, envPtr);
- }
- }
-
- /*
- * 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);
+ TclEmitInstInt4(INST_UPVAR, localIndex, envPtr);
}
/*
- * Clean up all our temporary space and return.
+ * Pop the frame index, and set the result to empty
*/
- TclStackFree(interp, finalFixups);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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);
- }
+ TclEmitOpcode(INST_POP, envPtr);
+ PushLiteral(envPtr, "", 0);
+ return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * TclCompileTryCmd --
+ * TclCompileVariableCmd --
*
- * Procedure called to compile the "try" command.
+ * 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 "try" command at
+ * Instructions are added to envPtr to execute the "variable" command at
* runtime.
*
*----------------------------------------------------------------------
*/
int
-TclCompileTryCmd(
+TclCompileVariableCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
@@ -5085,701 +3752,56 @@ TclCompileTryCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
- int numWords = parsePtr->numWords, numHandlers, result = TCL_ERROR;
- Tcl_Token *bodyToken, *finallyToken, *tokenPtr;
- Tcl_Token **handlerTokens = NULL;
- Tcl_Obj **matchClauses = NULL;
- int *matchCodes=NULL, *resultVarIndices=NULL, *optionVarIndices=NULL;
- int i;
+ Tcl_Token *varTokenPtr, *valueTokenPtr;
+ int localIndex, numWords, i;
+ DefineLineInformation; /* TIP #280 */
+ numWords = parsePtr->numWords;
if (numWords < 2) {
return TCL_ERROR;
}
- bodyToken = TokenAfter(parsePtr->tokenPtr);
-
- if (numWords == 2) {
- /*
- * No handlers or finally; do nothing beyond evaluating the body.
- */
-
- DefineLineInformation; /* TIP #280 */
- SetLineInformation(1);
- CompileBody(envPtr, bodyToken, interp);
- return TCL_OK;
- }
-
- numWords -= 2;
- tokenPtr = TokenAfter(bodyToken);
-
/*
- * Extract information about what handlers there are.
- */
-
- numHandlers = numWords >> 2;
- numWords -= numHandlers * 4;
- if (numHandlers > 0) {
- handlerTokens = TclStackAlloc(interp, sizeof(Tcl_Token*)*numHandlers);
- matchClauses = TclStackAlloc(interp, sizeof(Tcl_Obj *) * numHandlers);
- memset(matchClauses, 0, sizeof(Tcl_Obj *) * numHandlers);
- matchCodes = TclStackAlloc(interp, sizeof(int) * numHandlers);
- resultVarIndices = TclStackAlloc(interp, sizeof(int) * numHandlers);
- optionVarIndices = TclStackAlloc(interp, sizeof(int) * numHandlers);
-
- for (i=0 ; i<numHandlers ; i++) {
- Tcl_Obj *tmpObj, **objv;
- int objc;
-
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- goto failedToCompile;
- }
- if (tokenPtr[1].size == 4
- && !strncmp(tokenPtr[1].start, "trap", 4)) {
- /*
- * Parse the list of errorCode words to match against.
- */
-
- matchCodes[i] = TCL_ERROR;
- tokenPtr = TokenAfter(tokenPtr);
- TclNewObj(tmpObj);
- Tcl_IncrRefCount(tmpObj);
- if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)
- || Tcl_ListObjLength(NULL, tmpObj, &objc) != TCL_OK
- || (objc == 0)) {
- TclDecrRefCount(tmpObj);
- goto failedToCompile;
- }
- Tcl_ListObjReplace(NULL, tmpObj, 0, 0, 0, NULL);
- matchClauses[i] = tmpObj;
- } else if (tokenPtr[1].size == 2
- && !strncmp(tokenPtr[1].start, "on", 2)) {
- int code;
- static const char *codes[] = {
- "ok", "error", "return", "break", "continue", NULL
- };
-
- /*
- * Parse the result code to look for.
- */
-
- tokenPtr = TokenAfter(tokenPtr);
- TclNewObj(tmpObj);
- Tcl_IncrRefCount(tmpObj);
- if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
- TclDecrRefCount(tmpObj);
- goto failedToCompile;
- }
- if (Tcl_GetIntFromObj(NULL, tmpObj, &code) != TCL_OK
- && Tcl_GetIndexFromObj(NULL, tmpObj, codes, "",
- TCL_EXACT, &code) != TCL_OK) {
- TclDecrRefCount(tmpObj);
- goto failedToCompile;
- }
- matchCodes[i] = code;
- TclDecrRefCount(tmpObj);
- } else {
- goto failedToCompile;
- }
-
- /*
- * Parse the variable binding.
- */
-
- tokenPtr = TokenAfter(tokenPtr);
- TclNewObj(tmpObj);
- Tcl_IncrRefCount(tmpObj);
- if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
- TclDecrRefCount(tmpObj);
- goto failedToCompile;
- }
- if (Tcl_ListObjGetElements(NULL, tmpObj, &objc, &objv) != TCL_OK
- || (objc > 2)) {
- TclDecrRefCount(tmpObj);
- goto failedToCompile;
- }
- if (objc > 0) {
- int len;
- const char *varname = Tcl_GetStringFromObj(objv[0], &len);
-
- if (!TclIsLocalScalar(varname, len)) {
- TclDecrRefCount(tmpObj);
- goto failedToCompile;
- }
- resultVarIndices[i] =
- TclFindCompiledLocal(varname, len, 1, envPtr);
- } else {
- resultVarIndices[i] = -1;
- }
- if (objc == 2) {
- int len;
- const char *varname = Tcl_GetStringFromObj(objv[1], &len);
-
- if (!TclIsLocalScalar(varname, len)) {
- TclDecrRefCount(tmpObj);
- goto failedToCompile;
- }
- optionVarIndices[i] =
- TclFindCompiledLocal(varname, len, 1, envPtr);
- } else {
- optionVarIndices[i] = -1;
- }
- TclDecrRefCount(tmpObj);
-
- /*
- * Extract the body for this handler.
- */
-
- tokenPtr = TokenAfter(tokenPtr);
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- goto failedToCompile;
- }
- if (tokenPtr[1].size == 1 && tokenPtr[1].start[0] == '-') {
- handlerTokens[i] = NULL;
- } else {
- handlerTokens[i] = tokenPtr;
- }
-
- tokenPtr = TokenAfter(tokenPtr);
- }
-
- if (handlerTokens[numHandlers-1] == NULL) {
- goto failedToCompile;
- }
- }
-
- /*
- * Parse the finally clause
- */
-
- if (numWords == 0) {
- finallyToken = NULL;
- } else if (numWords == 2) {
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 7
- || strncmp(tokenPtr[1].start, "finally", 7)) {
- goto failedToCompile;
- }
- finallyToken = TokenAfter(tokenPtr);
- } else {
- goto failedToCompile;
- }
-
- /*
- * Issue the bytecode.
- */
-
- if (finallyToken) {
- result = IssueTryFinallyInstructions(interp, envPtr, bodyToken,
- numHandlers, matchCodes, matchClauses, resultVarIndices,
- optionVarIndices, handlerTokens, finallyToken);
- } else {
- result = IssueTryInstructions(interp, envPtr, bodyToken, numHandlers,
- matchCodes, matchClauses, resultVarIndices, optionVarIndices,
- handlerTokens);
- }
-
- /*
- * Delete any temporary state and finish off.
+ * Bail out if not compiling a proc body
*/
- failedToCompile:
- if (numHandlers > 0) {
- for (i=0 ; i<numHandlers ; i++) {
- if (matchClauses[i]) {
- TclDecrRefCount(matchClauses[i]);
- }
- }
- TclStackFree(interp, optionVarIndices);
- TclStackFree(interp, resultVarIndices);
- TclStackFree(interp, matchCodes);
- TclStackFree(interp, matchClauses);
- TclStackFree(interp, handlerTokens);
- }
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * IssueTryInstructions, IssueTryFinallyInstructions --
- *
- * The code generators for [try]. Split from the parsing engine for
- * reasons of developer sanity, and also split between no-finally and
- * with-finally cases because so many of the details of generation vary
- * between the two.
- *
- * The macros below make the instruction issuing easier to follow.
- *
- *----------------------------------------------------------------------
- */
-
-#define OP(name) TclEmitOpcode(INST_##name, envPtr)
-#define OP1(name,val) TclEmitInstInt1(INST_##name,(val),envPtr)
-#define OP4(name,val) TclEmitInstInt4(INST_##name,(val),envPtr)
-#define OP44(name,val1,val2) \
- TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr)
-#define BODY(token,index) \
- SetLineInformation((index));CompileBody(envPtr,(token),interp)
-#define PUSH(str) \
- PushLiteral(envPtr,(str),strlen(str))
-#define JUMP(var,name) \
- (var) = CurrentOffset(envPtr);TclEmitInstInt4(INST_##name,0,envPtr)
-#define FIXJUMP(var) \
- TclStoreInt4AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1)
-
-static int
-IssueTryInstructions(
- Tcl_Interp *interp,
- CompileEnv *envPtr,
- Tcl_Token *bodyToken,
- int numHandlers,
- int *matchCodes,
- Tcl_Obj **matchClauses,
- int *resultVars,
- int *optionVars,
- Tcl_Token **handlerTokens)
-{
- DefineLineInformation; /* TIP #280 */
- int range, resultVar, optionsVar;
- int i, j, len, forwardsNeedFixing = 0;
- int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
- char buf[TCL_INTEGER_SPACE];
-
- resultVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
- optionsVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
- if (resultVar < 0 || optionsVar < 0) {
+ if (envPtr->procPtr == NULL) {
return TCL_ERROR;
}
/*
- * Compile the body, trapping any error in it so that we can trap on it
- * and/or run a finally clause. Note that there must be at least one
- * on/trap clause; when none is present, this whole function is not called
- * (and it's never called when there's a finally clause).
- */
-
- range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
- OP4( BEGIN_CATCH4, range);
- ExceptionRangeStarts(envPtr, range);
- BODY( bodyToken, 1);
- ExceptionRangeEnds(envPtr, range);
- OP1( JUMP1, 3);
- ExceptionRangeTarget(envPtr, range, catchOffset);
- OP( PUSH_RESULT);
- OP4( STORE_SCALAR4, resultVar);
- OP( POP);
- OP( PUSH_RETURN_OPTIONS);
- OP4( STORE_SCALAR4, optionsVar);
- OP( POP);
- OP( PUSH_RETURN_CODE);
- OP( END_CATCH);
-
- /*
- * Now we handle all the registered 'on' and 'trap' handlers in order.
- * For us to be here, there must be at least one handler.
- *
- * Slight overallocation, but reduces size of this function.
+ * Loop over the (var, value) pairs.
*/
- addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
- forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
-
- for (i=0 ; i<numHandlers ; i++) {
- sprintf(buf, "%d", matchCodes[i]);
- OP( DUP);
- PUSH( buf);
- OP( EQ);
- JUMP(notCodeJumpSource, JUMP_FALSE4);
- if (matchClauses[i]) {
- Tcl_ListObjLength(NULL, matchClauses[i], &len);
-
- /*
- * Match the errorcode according to try/trap rules.
- */
-
- OP4( LOAD_SCALAR4, optionsVar);
- PUSH( "-errorcode");
- OP4( DICT_GET, 1);
- OP44( LIST_RANGE_IMM, 0, len-1);
- PUSH( TclGetString(matchClauses[i]));
- OP( STR_EQ);
- JUMP(notECJumpSource, JUMP_FALSE4);
- } else {
- notECJumpSource = -1; /* LINT */
- }
- OP( POP);
-
- /*
- * There is no finally clause, so we can avoid wrapping a catch
- * context around the handler. That simplifies what instructions need
- * to be issued a lot since we can let errors just fall through.
- */
+ valueTokenPtr = parsePtr->tokenPtr;
+ for (i=2; i<=numWords; i+=2) {
+ varTokenPtr = TokenAfter(valueTokenPtr);
+ valueTokenPtr = TokenAfter(varTokenPtr);
- if (resultVars[i] >= 0) {
- OP4( LOAD_SCALAR4, resultVar);
- OP4( STORE_SCALAR4, resultVars[i]);
- OP( POP);
- if (optionVars[i] >= 0) {
- OP4( LOAD_SCALAR4, optionsVar);
- OP4( STORE_SCALAR4, optionVars[i]);
- OP( POP);
- }
- }
- if (!handlerTokens[i]) {
- forwardsNeedFixing = 1;
- JUMP(forwardsToFix[i], JUMP4);
- } else {
- forwardsToFix[i] = -1;
- if (forwardsNeedFixing) {
- forwardsNeedFixing = 0;
- for (j=0 ; j<i ; j++) {
- if (forwardsToFix[j] == -1) {
- continue;
- }
- FIXJUMP(forwardsToFix[j]);
- forwardsToFix[j] = -1;
- }
- }
- BODY( handlerTokens[i], 5+i*4);
- }
+ localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
- JUMP(addrsToFix[i], JUMP4);
- if (matchClauses[i]) {
- FIXJUMP(notECJumpSource);
+ if (localIndex < 0) {
+ return TCL_ERROR;
}
- FIXJUMP(notCodeJumpSource);
- }
- /*
- * Drop the result code since it didn't match any clause, and reissue the
- * exception. Note also that INST_RETURN_STK can proceed to the next
- * instruction.
- */
-
- OP( POP);
- OP4( LOAD_SCALAR4, optionsVar);
- OP4( LOAD_SCALAR4, resultVar);
- OP( RETURN_STK);
-
- /*
- * Fix all the jumps from taken clauses to here (which is the end of the
- * [try]).
- */
-
- for (i=0 ; i<numHandlers ; i++) {
- FIXJUMP(addrsToFix[i]);
- }
- TclStackFree(interp, forwardsToFix);
- TclStackFree(interp, addrsToFix);
- return TCL_OK;
-}
-
-static int
-IssueTryFinallyInstructions(
- Tcl_Interp *interp,
- CompileEnv *envPtr,
- Tcl_Token *bodyToken,
- int numHandlers,
- int *matchCodes,
- Tcl_Obj **matchClauses,
- int *resultVars,
- int *optionVars,
- Tcl_Token **handlerTokens,
- Tcl_Token *finallyToken) /* Not NULL */
-{
- DefineLineInformation; /* TIP #280 */
- int savedStackDepth = envPtr->currStackDepth;
- int range, resultVar, optionsVar, i, j, len, forwardsNeedFixing = 0;
- int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
- char buf[TCL_INTEGER_SPACE];
-
- resultVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
- optionsVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
- if (resultVar < 0 || optionsVar < 0) {
- return TCL_ERROR;
- }
-
- /*
- * Compile the body, trapping any error in it so that we can trap on it
- * (if any trap matches) and run a finally clause.
- */
-
- range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
- OP4( BEGIN_CATCH4, range);
- ExceptionRangeStarts(envPtr, range);
- BODY( bodyToken, 1);
- ExceptionRangeEnds(envPtr, range);
- OP1( JUMP1, 3);
- ExceptionRangeTarget(envPtr, range, catchOffset);
- OP( PUSH_RESULT);
- OP4( STORE_SCALAR4, resultVar);
- OP( POP);
- OP( PUSH_RETURN_OPTIONS);
- OP4( STORE_SCALAR4, optionsVar);
- OP( POP);
- OP( PUSH_RETURN_CODE);
- OP( END_CATCH);
- envPtr->currStackDepth = savedStackDepth + 1;
-
- /*
- * Now we handle all the registered 'on' and 'trap' handlers in order.
- */
-
- if (numHandlers) {
- /*
- * Slight overallocation, but reduces size of this function.
- */
-
- addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
- forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
-
- for (i=0 ; i<numHandlers ; i++) {
- sprintf(buf, "%d", matchCodes[i]);
- OP( DUP);
- PUSH( buf);
- OP( EQ);
- JUMP(notCodeJumpSource, JUMP_FALSE4);
- if (matchClauses[i]) {
- Tcl_ListObjLength(NULL, matchClauses[i], &len);
-
- /*
- * Match the errorcode according to try/trap rules.
- */
-
- OP4( LOAD_SCALAR4, optionsVar);
- PUSH( "-errorcode");
- OP4( DICT_GET, 1);
- OP44( LIST_RANGE_IMM, 0, len-1);
- PUSH( TclGetString(matchClauses[i]));
- OP( STR_EQ);
- JUMP(notECJumpSource, JUMP_FALSE4);
- } else {
- notECJumpSource = -1; /* LINT */
- }
+ CompileWord(envPtr, varTokenPtr, interp, 1);
+ TclEmitInstInt4(INST_VARIABLE, localIndex, envPtr);
+ if (i != numWords) {
/*
- * There is a finally clause, so we need a fairly complex sequence
- * of instructions to deal with an on/trap handler because we must
- * call the finally handler *and* we need to substitute the result
- * from a failed trap for the result from the main script.
+ * A value has been given: set the variable, pop the value
*/
- if (resultVars[i] >= 0 || handlerTokens[i]) {
- range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
- OP4( BEGIN_CATCH4, range);
- ExceptionRangeStarts(envPtr, range);
- }
- if (resultVars[i] >= 0) {
- OP4( LOAD_SCALAR4, resultVar);
- OP4( STORE_SCALAR4, resultVars[i]);
- OP( POP);
- if (optionVars[i] >= 0) {
- OP4( LOAD_SCALAR4, optionsVar);
- OP4( STORE_SCALAR4, optionVars[i]);
- OP( POP);
- }
- }
- if (!handlerTokens[i]) {
- /*
- * No handler. Will not be the last handler (that condition is
- * checked by the caller). Chain to the next one.
- */
-
- ExceptionRangeEnds(envPtr, range);
- forwardsNeedFixing = 1;
- JUMP(forwardsToFix[i], JUMP4);
- if (resultVars[i] >= 0) {
- goto finishTrapCatchHandling;
- }
- } else {
- /*
- * Got a handler. Make sure that any pending patch-up actions
- * from previous unprocessed handlers are dealt with now that
- * we know where they are to jump to.
- */
-
- if (forwardsNeedFixing) {
- forwardsNeedFixing = 0;
- OP1( JUMP1, 7);
- for (j=0 ; j<i ; j++) {
- if (forwardsToFix[j] == -1) {
- continue;
- }
- FIXJUMP(forwardsToFix[j]);
- forwardsToFix[j] = -1;
- }
- OP4( BEGIN_CATCH4, range);
- }
- BODY( handlerTokens[i], 5+i*4);
- ExceptionRangeEnds(envPtr, range);
- OP( POP);
- OP1( JUMP1, 6);
- forwardsToFix[i] = -1;
-
- /*
- * Error in handler or setting of variables; replace the
- * stored exception with the new one. Note that we only push
- * this if we have either a body or some variable setting
- * here. Otherwise this code is unreachable.
- */
-
- finishTrapCatchHandling:
- ExceptionRangeTarget(envPtr, range, catchOffset);
- OP( PUSH_RESULT);
- OP4( STORE_SCALAR4, resultVar);
- OP( POP);
- OP( PUSH_RETURN_OPTIONS);
- OP4( STORE_SCALAR4, optionsVar);
- OP( POP);
- OP( END_CATCH);
- }
- if (i+1 < numHandlers) {
- JUMP(addrsToFix[i], JUMP4);
- }
- if (matchClauses[i]) {
- FIXJUMP(notECJumpSource);
- }
- FIXJUMP(notCodeJumpSource);
- }
-
- /*
- * Fix all the jumps from taken clauses to here (the start of the
- * finally clause).
- */
-
- for (i=0 ; i<numHandlers-1 ; i++) {
- FIXJUMP(addrsToFix[i]);
+ CompileWord(envPtr, valueTokenPtr, interp, 1);
+ TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
+ TclEmitOpcode(INST_POP, envPtr);
}
- TclStackFree(interp, forwardsToFix);
- TclStackFree(interp, addrsToFix);
}
/*
- * Drop the result code.
- */
-
- OP( POP);
- envPtr->currStackDepth = savedStackDepth;
-
- /*
- * Process the finally clause (at last!) Note that we do not wrap this in
- * error handlers because we would just rethrow immediately anyway. Then
- * (on normal success) we reissue the exception. Note also that
- * INST_RETURN_STK can proceed to the next instruction; that'll be the
- * next command (or some inter-command manipulation).
+ * Set the result to empty
*/
- BODY( finallyToken, 3 + 4*numHandlers);
- OP( POP);
- OP4( LOAD_SCALAR4, optionsVar);
- OP4( LOAD_SCALAR4, resultVar);
- OP( RETURN_STK);
-
- return TCL_OK;
-}
-
-#undef OP
-#undef OP1
-#undef OP4
-#undef OP44
-#undef BODY
-#undef PUSH
-#undef JUMP
-#undef FIXJUMP
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileUnsetCmd --
- *
- * Procedure called to compile the "unset" 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 "unset" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileUnsetCmd(
- 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 isScalar, simpleVarName, localIndex, numWords, flags, i;
- Tcl_Obj *leadingWord;
- DefineLineInformation; /* TIP #280 */
-
- numWords = parsePtr->numWords-1;
- flags = 1;
- varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- leadingWord = Tcl_NewObj();
- if (TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) {
- int len;
- const char *bytes = Tcl_GetStringFromObj(leadingWord, &len);
-
- if (len == 11 && !strncmp("-nocomplain", bytes, 11)) {
- flags = 0;
- varTokenPtr = TokenAfter(varTokenPtr);
- numWords--;
- } else if (len == 2 && !strncmp("--", bytes, 2)) {
- varTokenPtr = TokenAfter(varTokenPtr);
- numWords--;
- }
- } else {
- /*
- * Cannot guarantee that the first word is not '-nocomplain' at
- * evaluation with reasonable effort, so spill to interpreted version.
- */
-
- return TCL_ERROR;
- }
- TclDecrRefCount(leadingWord);
-
- for (i=0 ; i<numWords ; i++) {
- /*
- * 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.
- */
-
- PushVarNameWord(interp, varTokenPtr, envPtr, 0,
- &localIndex, &simpleVarName, &isScalar, 1);
-
- /*
- * Emit instructions to unset the variable.
- */
-
- if (!simpleVarName) {
- TclEmitInstInt1( INST_UNSET_STK, flags, envPtr);
- } else if (isScalar) {
- if (localIndex < 0) {
- TclEmitInstInt1(INST_UNSET_STK, flags, envPtr);
- } else {
- TclEmitInstInt1(INST_UNSET_SCALAR, flags, envPtr);
- TclEmitInt4( localIndex, envPtr);
- }
- } else {
- if (localIndex < 0) {
- TclEmitInstInt1(INST_UNSET_ARRAY_STK, flags, envPtr);
- } else {
- TclEmitInstInt1(INST_UNSET_ARRAY, flags, envPtr);
- TclEmitInt4( localIndex, envPtr);
- }
- }
-
- varTokenPtr = TokenAfter(varTokenPtr);
- }
PushLiteral(envPtr, "", 0);
return TCL_OK;
}
@@ -5787,180 +3809,97 @@ TclCompileUnsetCmd(
/*
*----------------------------------------------------------------------
*
- * TclCompileWhileCmd --
+ * IndexTailVarIfKnown --
*
- * Procedure called to compile the "while" command.
+ * 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 TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * Returns the variable's index in the table of compiled locals if the
+ * tail is known at compile time, or -1 otherwise.
*
* Side effects:
- * Instructions are added to envPtr to execute the "while" command at
- * runtime.
+ * None.
*
*----------------------------------------------------------------------
*/
-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. */
+static int
+IndexTailVarIfKnown(
+ Tcl_Interp *interp,
+ Tcl_Token *varTokenPtr, /* Token representing the variable name */
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;
- }
+ Tcl_Obj *tailPtr;
+ const char *tailName, *p;
+ int len, n = varTokenPtr->numComponents;
+ Tcl_Token *lastTokenPtr;
+ int full, localIndex;
/*
- * 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" {}".
+ * 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.
*
- * Bail out also if the body expression requires substitutions in order to
- * insure correct behaviour [Bug 219166]
+ * 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.
*/
- testTokenPtr = TokenAfter(parsePtr->tokenPtr);
- bodyTokenPtr = TokenAfter(testTokenPtr);
-
- if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
- || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
- return TCL_ERROR;
+ if (!EnvHasLVT(envPtr)) {
+ return -1;
}
- /*
- * Find out if the condition is a constant.
- */
+ 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;
+ }
+ }
- 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.
- */
+ tailName = TclGetStringFromObj(tailPtr, &len);
- loopMayEnd = 0;
- } else {
+ if (len) {
+ if (*(tailName+len-1) == ')') {
/*
- * This is an empty loop: "while 0 {...}" or such. Compile no
- * bytecodes.
+ * Possible array: bail out
*/
- goto pushResult;
+ Tcl_DecrRefCount(tailPtr);
+ return -1;
}
- }
-
- /*
- * 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. */
- } else {
/*
- * Make sure that the first command in the body is preceded by an
- * INST_START_CMD, and hence counted properly. [Bug 1752146]
+ * Get the tail: immediately after the last '::'
*/
- 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;
+ for (p = tailName + len -1; p > tailName; p--) {
+ if ((*p == ':') && (*(p-1) == ':')) {
+ p++;
+ break;
+ }
}
- envPtr->currStackDepth = savedStackDepth;
- SetLineInformation(1);
- TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
- envPtr->currStackDepth = savedStackDepth + 1;
+ if (!full && (p == tailName)) {
+ /*
+ * No :: in the last component.
+ */
- 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);
+ Tcl_DecrRefCount(tailPtr);
+ return -1;
}
+ len -= p - tailName;
+ tailName = p;
}
- /*
- * 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;
+ localIndex = TclFindCompiledLocal(tailName, len, 1, envPtr);
+ Tcl_DecrRefCount(tailPtr);
+ return localIndex;
}
/*
@@ -6204,1111 +4143,6 @@ PushVarName(
}
/*
- *----------------------------------------------------------------------
- *
- * 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);
- 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 (!EnvHasLVT(envPtr)) {
- 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, 1, envPtr);
- 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 simpleVarName, isScalar, localIndex, numWords, i;
- DefineLineInformation; /* TIP #280 */
- Tcl_Obj *objPtr = Tcl_NewObj();
-
- if (envPtr->procPtr == NULL) {
- Tcl_DecrRefCount(objPtr);
- return TCL_ERROR;
- }
-
- numWords = parsePtr->numWords;
- if (numWords < 3) {
- Tcl_DecrRefCount(objPtr);
- return TCL_ERROR;
- }
-
- /*
- * Push the frame index if it is known at compile time
- */
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
- CallFrame *framePtr;
- const 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;
- }
- CompileWord(envPtr, tokenPtr, interp, 1);
- otherTokenPtr = TokenAfter(tokenPtr);
- i = 4;
- } else {
- if (!(numWords%2)) {
- return TCL_ERROR;
- }
- PushLiteral(envPtr, "1", 1);
- otherTokenPtr = tokenPtr;
- i = 3;
- }
- } 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, 1);
- PushVarNameWord(interp, localTokenPtr, envPtr, 0,
- &localIndex, &simpleVarName, &isScalar, 1);
-
- if ((localIndex < 0) || !isScalar) {
- 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 simpleVarName, isScalar, 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, 1);
-
- /*
- * 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=4; i<=numWords; i+=2) {
- otherTokenPtr = TokenAfter(localTokenPtr);
- localTokenPtr = TokenAfter(otherTokenPtr);
-
- CompileWord(envPtr, otherTokenPtr, interp, 1);
- PushVarNameWord(interp, localTokenPtr, envPtr, 0,
- &localIndex, &simpleVarName, &isScalar, 1);
-
- if ((localIndex < 0) || !isScalar) {
- 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=2; i<=numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) {
- localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
-
- if (localIndex < 0) {
- return TCL_ERROR;
- }
-
- CompileWord(envPtr, varTokenPtr, interp, 1);
- 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=2; i<=numWords; i+=2) {
- varTokenPtr = TokenAfter(valueTokenPtr);
- valueTokenPtr = TokenAfter(varTokenPtr);
-
- localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
-
- if (localIndex < 0) {
- return TCL_ERROR;
- }
-
- CompileWord(envPtr, varTokenPtr, interp, 1);
- TclEmitInstInt4(INST_VARIABLE, localIndex, envPtr);
-
- if (i != numWords) {
- /*
- * A value has been given: set the variable, pop the value
- */
-
- CompileWord(envPtr, valueTokenPtr, interp, 1);
- TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
- TclEmitOpcode(INST_POP, envPtr);
- }
- }
-
- /*
- * Set the result to empty
- */
-
- PushLiteral(envPtr, "", 0);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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, 0, &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;
-}
-
-/*
* Local Variables:
* mode: c
* c-basic-offset: 4