summaryrefslogtreecommitdiffstats
path: root/generic/tclCompCmds.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclCompCmds.c')
-rw-r--r--generic/tclCompCmds.c6484
1 files changed, 4745 insertions, 1739 deletions
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index a39370e..9eb74f5 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -1,54 +1,49 @@
-/*
+/*
* tclCompCmds.c --
*
- * This file contains compilation procedures that compile various
- * Tcl commands into a sequence of instructions ("bytecodes").
+ * This file contains compilation procedures that compile various Tcl
+ * commands into a sequence of instructions ("bytecodes").
*
* Copyright (c) 1997-1998 Sun Microsystems, Inc.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
* Copyright (c) 2002 ActiveState Corporation.
+ * Copyright (c) 2004-2006 by Donal K. Fellows.
*
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclCompile.h"
/*
- * Prototypes for procedures defined later in this file:
+ * Macro that encapsulates an efficiency trick that avoids a function call for
+ * the simplest of compiles. The ANSI C "prototype" for this macro is:
+ *
+ * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr,
+ * Tcl_Interp *interp, int word);
*/
-static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData));
-static void FreeForeachInfo _ANSI_ARGS_((ClientData clientData));
-#ifndef TCL_TIP280
-static int TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags,
- int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr));
-
-#define TclPushVarNameWord(i,v,e,f,l,s,sc,word) \
- TclPushVarName (i,v,e,f,l,s,sc) /* ignoring word */
-
-#define DefineLineInformation /**/
-#define SetLineInformation(word) /**/
-#else
-static int TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags,
- int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr,
- int line, int* clNext));
-
-#define TclPushVarNameWord(i,v,e,f,l,s,sc,word) \
- TclPushVarName (i,v,e,f,l,s,sc, \
- mapPtr->loc [eclIndex].line [(word)], \
- mapPtr->loc [eclIndex].next [(word)])
+#define CompileWord(envPtr, tokenPtr, interp, word) \
+ if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \
+ TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \
+ (tokenPtr)[1].size), (envPtr)); \
+ } else { \
+ envPtr->line = mapPtr->loc[eclIndex].line[word]; \
+ envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \
+ TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
+ (envPtr)); \
+ }
-/* TIP #280 : Remember the per-word line information of the current
- * command. An index is used instead of a pointer as recursive compilation may
- * reallocate, i.e. move, the array. This is also the reason to save the nuloc
- * now, it may change during the course of the function.
+/*
+ * TIP #280: Remember the per-word line information of the current command. An
+ * index is used instead of a pointer as recursive compilation may reallocate,
+ * i.e. move, the array. This is also the reason to save the nuloc now, it may
+ * change during the course of the function.
*
- * Macros to encapsulate the variable definition and setup, and their use.
+ * Macro to encapsulate the variable definition and setup.
*/
+
#define DefineLineInformation \
ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
int eclIndex = mapPtr->nuloc - 1
@@ -56,23 +51,163 @@ static int TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp,
#define SetLineInformation(word) \
envPtr->line = mapPtr->loc [eclIndex].line [(word)]; \
envPtr->clNext = mapPtr->loc [eclIndex].next [(word)]
-#endif
/*
- * Flags bits used by TclPushVarName.
+ * Convenience macro for use when compiling bodies of commands. The ANSI C
+ * "prototype" for this macro is:
+ *
+ * static void CompileBody(CompileEnv *envPtr, Tcl_Token *tokenPtr,
+ * Tcl_Interp *interp);
+ */
+
+#define CompileBody(envPtr, tokenPtr, interp) \
+ TclCompileCmdWord((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
+ (envPtr))
+
+/*
+ * Convenience macro for use when compiling tokens to be pushed. The ANSI C
+ * "prototype" for this macro is:
+ *
+ * static void CompileTokens(CompileEnv *envPtr, Tcl_Token *tokenPtr,
+ * Tcl_Interp *interp);
+ */
+
+#define CompileTokens(envPtr, tokenPtr, interp) \
+ TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
+ (envPtr));
+/*
+ * Convenience macro for use when pushing literals. The ANSI C "prototype" for
+ * this macro is:
+ *
+ * static void PushLiteral(CompileEnv *envPtr,
+ * const char *string, int length);
+ */
+
+#define PushLiteral(envPtr, string, length) \
+ TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr))
+
+/*
+ * Macro to advance to the next token; it is more mnemonic than the address
+ * arithmetic that it replaces. The ANSI C "prototype" for this macro is:
+ *
+ * static Tcl_Token * TokenAfter(Tcl_Token *tokenPtr);
+ */
+
+#define TokenAfter(tokenPtr) \
+ ((tokenPtr) + ((tokenPtr)->numComponents + 1))
+
+/*
+ * Macro to get the offset to the next instruction to be issued. The ANSI C
+ * "prototype" for this macro is:
+ *
+ * static int CurrentOffset(CompileEnv *envPtr);
+ */
+
+#define CurrentOffset(envPtr) \
+ ((envPtr)->codeNext - (envPtr)->codeStart)
+
+/*
+ * Note: the exceptDepth is a bit of a misnomer: TEBC only needs the
+ * maximal depth of nested CATCH ranges in order to alloc runtime
+ * memory. These macros should compute precisely that? OTOH, the nesting depth
+ * of LOOP ranges is an interesting datum for debugging purposes, and that is
+ * what we compute now.
+ *
+ * static int DeclareExceptionRange(CompileEnv *envPtr, int type);
+ * static int ExceptionRangeStarts(CompileEnv *envPtr, int index);
+ * static void ExceptionRangeEnds(CompileEnv *envPtr, int index);
+ * static void ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL);
+ */
+
+#define DeclareExceptionRange(envPtr, type) \
+ (TclCreateExceptRange((type), (envPtr)))
+#define ExceptionRangeStarts(envPtr, index) \
+ (((envPtr)->exceptDepth++), \
+ ((envPtr)->maxExceptDepth = \
+ TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \
+ ((envPtr)->exceptArrayPtr[(index)].codeOffset = CurrentOffset(envPtr)))
+#define ExceptionRangeEnds(envPtr, index) \
+ (((envPtr)->exceptDepth--), \
+ ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \
+ CurrentOffset(envPtr) - (envPtr)->exceptArrayPtr[(index)].codeOffset))
+#define ExceptionRangeTarget(envPtr, index, targetType) \
+ ((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr))
+
+/*
+ * Prototypes for procedures defined later in this file:
*/
-#define TCL_CREATE_VAR 1 /* Create a compiled local if none is found */
-#define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */
+static ClientData DupDictUpdateInfo(ClientData clientData);
+static void FreeDictUpdateInfo(ClientData clientData);
+static void PrintDictUpdateInfo(ClientData clientData,
+ Tcl_Obj *appendObj, ByteCode *codePtr,
+ unsigned int pcOffset);
+static ClientData DupForeachInfo(ClientData clientData);
+static void FreeForeachInfo(ClientData clientData);
+static void PrintForeachInfo(ClientData clientData,
+ Tcl_Obj *appendObj, ByteCode *codePtr,
+ unsigned int pcOffset);
+static ClientData DupJumptableInfo(ClientData clientData);
+static void FreeJumptableInfo(ClientData clientData);
+static void PrintJumptableInfo(ClientData clientData,
+ Tcl_Obj *appendObj, ByteCode *codePtr,
+ unsigned int pcOffset);
+static int PushVarName(Tcl_Interp *interp,
+ Tcl_Token *varTokenPtr, CompileEnv *envPtr,
+ int flags, int *localIndexPtr,
+ int *simpleVarNamePtr, int *isScalarPtr,
+ int line, int* clNext);
+static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, const char *identity,
+ int instruction, CompileEnv *envPtr);
+static int CompileComparisonOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, int instruction,
+ CompileEnv *envPtr);
+static int CompileStrictlyBinaryOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, int instruction,
+ CompileEnv *envPtr);
+static int CompileUnaryOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, int instruction,
+ CompileEnv *envPtr);
+static void CompileReturnInternal(CompileEnv *envPtr,
+ unsigned char op, int code, int level,
+ Tcl_Obj *returnOpts);
+
+#define PushVarNameWord(i,v,e,f,l,s,sc,word) \
+ PushVarName (i,v,e,f,l,s,sc, \
+ mapPtr->loc [eclIndex].line [(word)], \
+ mapPtr->loc [eclIndex].next [(word)])
+
+/*
+ * Flags bits used by PushVarName.
+ */
+
+#define TCL_CREATE_VAR 1 /* Create a compiled local if none is found */
+#define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */
/*
* The structures below define the AuxData types defined in this file.
*/
AuxDataType tclForeachInfoType = {
- "ForeachInfo", /* name */
- DupForeachInfo, /* dupProc */
- FreeForeachInfo /* freeProc */
+ "ForeachInfo", /* name */
+ DupForeachInfo, /* dupProc */
+ FreeForeachInfo, /* freeProc */
+ PrintForeachInfo /* printProc */
+};
+
+AuxDataType tclJumptableInfoType = {
+ "JumptableInfo", /* name */
+ DupJumptableInfo, /* dupProc */
+ FreeJumptableInfo, /* freeProc */
+ PrintJumptableInfo /* printProc */
+};
+
+AuxDataType tclDictUpdateInfoType = {
+ "DictUpdateInfo", /* name */
+ DupDictUpdateInfo, /* dupProc */
+ FreeDictUpdateInfo, /* freeProc */
+ PrintDictUpdateInfo /* printProc */
};
/*
@@ -83,89 +218,68 @@ AuxDataType tclForeachInfoType = {
* Procedure called to compile the "append" command.
*
* Results:
- * The return value is a standard Tcl result, which is normally TCL_OK
- * unless there was an error while parsing string. If an error occurs
- * then the interpreter's result contains a standard error message. If
- * compilation fails because the command requires a second level of
- * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
- * command should be compiled "out of line" by emitting code to
- * invoke its command procedure (Tcl_AppendObjCmd) at runtime.
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
*
* Side effects:
- * Instructions are added to envPtr to execute the "append" command
- * at runtime.
+ * Instructions are added to envPtr to execute the "append" command at
+ * runtime.
*
*----------------------------------------------------------------------
*/
int
-TclCompileAppendCmd(interp, parsePtr, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- Tcl_Parse *parsePtr; /* Points to a parse structure for the
- * command created by Tcl_ParseCommand. */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+TclCompileAppendCmd(
+ 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 simpleVarName, isScalar, localIndex, numWords;
- int code = TCL_OK;
-
- DefineLineInformation;
+ DefineLineInformation; /* TIP #280 */
numWords = parsePtr->numWords;
if (numWords == 1) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"append varName ?value value ...?\"",
- -1);
return TCL_ERROR;
} else if (numWords == 2) {
/*
- * append varName === set varName
+ * append varName == set varName
*/
- return TclCompileSetCmd(interp, parsePtr, envPtr);
+
+ return TclCompileSetCmd(interp, parsePtr, cmdPtr, envPtr);
} else if (numWords > 3) {
/*
- * APPEND instructions currently only handle one value
+ * APPEND instructions currently only handle one value.
*/
- return TCL_OUT_LINE_COMPILE;
+
+ 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.
+ * 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 = parsePtr->tokenPtr
- + (parsePtr->tokenPtr->numComponents + 1);
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- code = TclPushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
- &localIndex, &simpleVarName, &isScalar, 1);
- if (code != TCL_OK) {
- goto done;
- }
+ PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
+ &localIndex, &simpleVarName, &isScalar, 1);
/*
- * We are doing an assignment, otherwise TclCompileSetCmd was called,
- * so push the new value. This will need to be extended to push a
- * value for each argument.
+ * We are doing an assignment, otherwise TclCompileSetCmd was called, so
+ * push the new value. This will need to be extended to push a value for
+ * each argument.
*/
if (numWords > 2) {
- valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
- if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- TclEmitPush(TclRegisterNewLiteral(envPtr,
- valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
- } else {
- SetLineInformation (2);
- code = TclCompileTokens(interp, valueTokenPtr+1,
- valueTokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- goto done;
- }
- }
+ valueTokenPtr = TokenAfter(varTokenPtr);
+ CompileWord(envPtr, valueTokenPtr, interp, 2);
}
/*
@@ -174,32 +288,27 @@ TclCompileAppendCmd(interp, parsePtr, envPtr)
if (simpleVarName) {
if (isScalar) {
- if (localIndex >= 0) {
- if (localIndex <= 255) {
- TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr);
- }
- } else {
+ if (localIndex < 0) {
TclEmitOpcode(INST_APPEND_STK, envPtr);
+ } else if (localIndex <= 255) {
+ TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr);
+ } else {
+ TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr);
}
} else {
- if (localIndex >= 0) {
- if (localIndex <= 255) {
- TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr);
- }
- } else {
+ if (localIndex < 0) {
TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr);
+ } else if (localIndex <= 255) {
+ TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr);
+ } else {
+ TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr);
}
}
} else {
TclEmitOpcode(INST_APPEND_STK, envPtr);
}
- done:
- return code;
+ return TCL_OK;
}
/*
@@ -210,28 +319,26 @@ TclCompileAppendCmd(interp, parsePtr, envPtr)
* Procedure called to compile the "break" command.
*
* Results:
- * The return value is a standard Tcl result, which is TCL_OK unless
- * there was an error during compilation. If an error occurs then
- * the interpreter's result contains a standard error message.
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
*
* Side effects:
- * Instructions are added to envPtr to execute the "break" command
- * at runtime.
+ * Instructions are added to envPtr to execute the "break" command at
+ * runtime.
*
*----------------------------------------------------------------------
*/
int
-TclCompileBreakCmd(interp, parsePtr, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- Tcl_Parse *parsePtr; /* Points to a parse structure for the
- * command created by Tcl_ParseCommand. */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+TclCompileBreakCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
{
if (parsePtr->numWords != 1) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"break\"", -1);
return TCL_ERROR;
}
@@ -251,172 +358,239 @@ TclCompileBreakCmd(interp, parsePtr, envPtr)
* Procedure called to compile the "catch" command.
*
* Results:
- * The return value is a standard Tcl result, which is TCL_OK if
- * compilation was successful. If an error occurs then the
- * interpreter's result contains a standard error message and TCL_ERROR
- * is returned. If the command is too complex for TclCompileCatchCmd,
- * TCL_OUT_LINE_COMPILE is returned indicating that the catch command
- * should be compiled "out of line" by emitting code to invoke its
- * command procedure at runtime.
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
*
* Side effects:
- * Instructions are added to envPtr to execute the "catch" command
- * at runtime.
+ * Instructions are added to envPtr to execute the "catch" command at
+ * runtime.
*
*----------------------------------------------------------------------
*/
int
-TclCompileCatchCmd(interp, parsePtr, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- Tcl_Parse *parsePtr; /* Points to a parse structure for the
- * command created by Tcl_ParseCommand. */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+TclCompileCatchCmd(
+ 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. */
{
JumpFixup jumpFixup;
- Tcl_Token *cmdTokenPtr, *nameTokenPtr;
- CONST char *name;
- int localIndex, nameChars, range, startOffset, jumpDist;
- int code;
- int savedStackDepth = envPtr->currStackDepth;
+ Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr;
+ const char *name;
+ int resultIndex, optsIndex, nameChars, range;
+ int initStackDepth = envPtr->currStackDepth;
+ int savedStackDepth;
+ DefineLineInformation; /* TIP #280 */
- DefineLineInformation;
+ /*
+ * If syntax does not match what we expect for [catch], do not compile.
+ * Let runtime checks determine if syntax has changed.
+ */
- if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"catch command ?varName?\"", -1);
+ if ((parsePtr->numWords < 2) || (parsePtr->numWords > 4)) {
return TCL_ERROR;
}
/*
- * If a variable was specified and the catch command is at global level
- * (not in a procedure), don't compile it inline: the payoff is
- * too small.
+ * If variables were specified and the catch command is at global level
+ * (not in a procedure), don't compile it inline: the payoff is too small.
*/
- if ((parsePtr->numWords == 3) && (envPtr->procPtr == NULL)) {
- return TCL_OUT_LINE_COMPILE;
+ if ((parsePtr->numWords >= 3) && (envPtr->procPtr == NULL)) {
+ return TCL_ERROR;
}
/*
- * Make sure the variable name, if any, has no substitutions and just
- * refers to a local scaler.
+ * Make sure the variable names, if any, have no substitutions and just
+ * refer to local scalars.
*/
- localIndex = -1;
- cmdTokenPtr = parsePtr->tokenPtr
- + (parsePtr->tokenPtr->numComponents + 1);
- if (parsePtr->numWords == 3) {
- nameTokenPtr = cmdTokenPtr + (cmdTokenPtr->numComponents + 1);
- if (nameTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- name = nameTokenPtr[1].start;
- nameChars = nameTokenPtr[1].size;
+ resultIndex = optsIndex = -1;
+ cmdTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ if (parsePtr->numWords >= 3) {
+ resultNameTokenPtr = TokenAfter(cmdTokenPtr);
+ /* DGP */
+ if (resultNameTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+
+ name = resultNameTokenPtr[1].start;
+ nameChars = resultNameTokenPtr[1].size;
+ if (!TclIsLocalScalar(name, nameChars)) {
+ return TCL_ERROR;
+ }
+ resultIndex = TclFindCompiledLocal(resultNameTokenPtr[1].start,
+ resultNameTokenPtr[1].size, /*create*/ 1, envPtr->procPtr);
+ if (resultIndex < 0) {
+ return TCL_ERROR;
+ }
+
+ /* DKF */
+ if (parsePtr->numWords == 4) {
+ optsNameTokenPtr = TokenAfter(resultNameTokenPtr);
+ if (optsNameTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ name = optsNameTokenPtr[1].start;
+ nameChars = optsNameTokenPtr[1].size;
if (!TclIsLocalScalar(name, nameChars)) {
- return TCL_OUT_LINE_COMPILE;
+ return TCL_ERROR;
+ }
+ optsIndex = TclFindCompiledLocal(optsNameTokenPtr[1].start,
+ optsNameTokenPtr[1].size, /*create*/ 1, envPtr->procPtr);
+ if (optsIndex < 0) {
+ return TCL_ERROR;
}
- localIndex = TclFindCompiledLocal(nameTokenPtr[1].start,
- nameTokenPtr[1].size, /*create*/ 1,
- /*flags*/ VAR_SCALAR, envPtr->procPtr);
- } else {
- return TCL_OUT_LINE_COMPILE;
}
}
/*
- * We will compile the catch command. Emit a beginCatch instruction at
- * the start of the catch body: the subcommand it controls.
+ * We will compile the catch command. Declare the exception range
+ * that it uses.
*/
-
- envPtr->exceptDepth++;
- envPtr->maxExceptDepth =
- TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
- range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
- TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);
+
+ range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
/*
- * If the body is a simple word, compile the instructions to
- * eval it. Otherwise, compile instructions to substitute its
- * text without catching, a catch instruction that resets the
- * stack to what it was before substituting the body, and then
- * an instruction to eval the body. Care has to be taken to
- * register the correct startOffset for the catch range so that
- * errors in the substitution are not catched [Bug 219184]
+ * If the body is a simple word, compile a BEGIN_CATCH instruction,
+ * followed by the instructions to eval the body.
+ * Otherwise, compile instructions to substitute the body text before
+ * starting the catch, then BEGIN_CATCH, and then EVAL_STK to
+ * evaluate the substituted body.
+ * Care has to be taken to make sure that substitution happens outside
+ * the catch range so that errors in the substitution are not caught.
+ * [Bug 219184]
+ * The reason for duplicating the script is that EVAL_STK would otherwise
+ * begin by undeflowing the stack below the mark set by BEGIN_CATCH4.
*/
- SetLineInformation (1);
+ SetLineInformation(1);
if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- startOffset = (envPtr->codeNext - envPtr->codeStart);
- code = TclCompileCmdWord(interp, cmdTokenPtr+1, 1, envPtr);
+ savedStackDepth = envPtr->currStackDepth;
+ TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);
+ ExceptionRangeStarts(envPtr, range);
+ CompileBody(envPtr, cmdTokenPtr, interp);
} else {
- code = TclCompileTokens(interp, cmdTokenPtr+1,
- cmdTokenPtr->numComponents, envPtr);
- startOffset = (envPtr->codeNext - envPtr->codeStart);
+ CompileTokens(envPtr, cmdTokenPtr, interp);
+ savedStackDepth = envPtr->currStackDepth;
+ TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);
+ ExceptionRangeStarts(envPtr, range);
+ TclEmitOpcode(INST_DUP, envPtr);
TclEmitOpcode(INST_EVAL_STK, envPtr);
}
- envPtr->exceptArrayPtr[range].codeOffset = startOffset;
+ /* Stack at this point:
+ * nonsimple: script <mark> result
+ * simple: <mark> result
+ */
- if (code != TCL_OK) {
- code = TCL_OUT_LINE_COMPILE;
- goto done;
- }
- envPtr->exceptArrayPtr[range].numCodeBytes =
- (envPtr->codeNext - envPtr->codeStart) - startOffset;
-
/*
- * The "no errors" epilogue code: store the body's result into the
- * variable (if any), push "0" (TCL_OK) as the catch's "no error"
+ * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch
* result, and jump around the "error case" code.
*/
- if (localIndex != -1) {
- if (localIndex <= 255) {
- TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
+ PushLiteral(envPtr, "0", 1);
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
+ /* Stack at this point: ?script? <mark> result TCL_OK */
+
+ /*
+ * Emit the "error case" epilogue. Push the interpreter result
+ * and the return code.
+ */
+
+ envPtr->currStackDepth = savedStackDepth;
+ ExceptionRangeTarget(envPtr, range, catchOffset);
+ /* Stack at this point: ?script? */
+ TclEmitOpcode(INST_PUSH_RESULT, envPtr);
+ TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
+
+ /*
+ * Update the target of the jump after the "no errors" code.
+ */
+
+ /* Stack at this point: ?script? result returnCode */
+ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
+ Tcl_Panic("TclCompileCatchCmd: bad jump distance %d",
+ (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
+ }
+
+ /* Push the return options if the caller wants them */
+
+ if (optsIndex != -1) {
+ TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr);
+ }
+
+ /*
+ * End the catch
+ */
+
+ ExceptionRangeEnds(envPtr, range);
+ TclEmitOpcode(INST_END_CATCH, envPtr);
+
+ /*
+ * At this point, the top of the stack is inconveniently ordered:
+ * ?script? result returnCode ?returnOptions?
+ * Reverse the stack to bring the result to the top.
+ */
+
+ if (optsIndex != -1) {
+ TclEmitInstInt4(INST_REVERSE, 3, envPtr);
+ } else {
+ TclEmitInstInt4(INST_REVERSE, 2, envPtr);
+ }
+
+ /*
+ * Store the result if requested, and remove it from the stack
+ */
+
+ if (resultIndex != -1) {
+ if (resultIndex <= 255) {
+ TclEmitInstInt1(INST_STORE_SCALAR1, resultIndex, envPtr);
} else {
- TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
+ TclEmitInstInt4(INST_STORE_SCALAR4, resultIndex, envPtr);
}
}
TclEmitOpcode(INST_POP, envPtr);
- TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr);
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
/*
- * The "error case" code: store the body's result into the variable (if
- * any), then push the error result code. The initial PC offset here is
- * the catch's error target.
+ * Stack is now ?script? ?returnOptions? returnCode.
+ * If the options dict has been requested, it is buried on the stack
+ * under the return code. Reverse the stack to bring it to the top,
+ * store it and remove it from the stack.
*/
- envPtr->currStackDepth = savedStackDepth;
- envPtr->exceptArrayPtr[range].catchOffset =
- (envPtr->codeNext - envPtr->codeStart);
- if (localIndex != -1) {
- TclEmitOpcode(INST_PUSH_RESULT, envPtr);
- if (localIndex <= 255) {
- TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
+ if (optsIndex != -1) {
+ TclEmitInstInt4(INST_REVERSE, 2, envPtr);
+ if (optsIndex <= 255) {
+ TclEmitInstInt1(INST_STORE_SCALAR1, optsIndex, envPtr);
} else {
- TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
+ TclEmitInstInt4(INST_STORE_SCALAR4, optsIndex, envPtr);
}
TclEmitOpcode(INST_POP, envPtr);
}
- TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
-
/*
- * Update the target of the jump after the "no errors" code, then emit
- * an endCatch instruction at the end of the catch command.
+ * Stack is now ?script? result. Get rid of the subst'ed script
+ * if it's hanging arond.
*/
- jumpDist = (envPtr->codeNext - envPtr->codeStart)
- - jumpFixup.codeOffset;
- if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
- panic("TclCompileCatchCmd: bad jump distance %d\n", jumpDist);
+ if (cmdTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ TclEmitInstInt4(INST_REVERSE, 2, envPtr);
+ TclEmitOpcode(INST_POP, envPtr);
}
- TclEmitOpcode(INST_END_CATCH, envPtr);
- done:
- envPtr->currStackDepth = savedStackDepth + 1;
- envPtr->exceptDepth--;
- return code;
+ /*
+ * Result of all this, on either branch, should have been to leave
+ * one operand -- the return code -- on the stack.
+ */
+
+ if (envPtr->currStackDepth != initStackDepth + 1) {
+ Tcl_Panic("in TclCompileCatchCmd, currStackDepth = %d should be %d",
+ envPtr->currStackDepth, initStackDepth+1);
+ }
+ return TCL_OK;
}
/*
@@ -427,32 +601,30 @@ TclCompileCatchCmd(interp, parsePtr, envPtr)
* Procedure called to compile the "continue" command.
*
* Results:
- * The return value is a standard Tcl result, which is TCL_OK unless
- * there was an error while parsing string. If an error occurs then
- * the interpreter's result contains a standard error message.
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
*
* Side effects:
- * Instructions are added to envPtr to execute the "continue" command
- * at runtime.
+ * Instructions are added to envPtr to execute the "continue" command at
+ * runtime.
*
*----------------------------------------------------------------------
*/
int
-TclCompileContinueCmd(interp, parsePtr, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- Tcl_Parse *parsePtr; /* Points to a parse structure for the
- * command created by Tcl_ParseCommand. */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+TclCompileContinueCmd(
+ 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. */
{
/*
* There should be no argument after the "continue".
*/
if (parsePtr->numWords != 1) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"continue\"", -1);
return TCL_ERROR;
}
@@ -467,45 +639,789 @@ TclCompileContinueCmd(interp, parsePtr, envPtr)
/*
*----------------------------------------------------------------------
*
+ * TclCompileDict*Cmd --
+ *
+ * Functions called to compile "dict" sucommands.
+ *
+ * Results:
+ * All return TCL_OK for a successful compile, and TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "dict" subcommand at
+ * runtime.
+ *
+ * Notes:
+ * The following commands are in fairly common use and are possibly worth
+ * bytecoding:
+ * dict append
+ * dict create [*]
+ * dict exists [*]
+ * dict for
+ * dict get [*]
+ * dict incr
+ * dict keys [*]
+ * dict lappend
+ * dict set
+ * dict unset
+ *
+ * In practice, those that are pure-value operators (marked with [*]) can
+ * probably be left alone (except perhaps [dict get] which is very very
+ * common) and [dict update] should be considered instead (really big
+ * win!)
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileDictSetCmd(
+ Tcl_Interp *interp, /* Used for looking up stuff. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr;
+ int numWords, i;
+ Proc *procPtr = envPtr->procPtr;
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *varTokenPtr;
+ int dictVarIndex, nameChars;
+ const char *name;
+
+ /*
+ * There must be at least one argument after the command.
+ */
+
+ if (parsePtr->numWords < 4 || procPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * The dictionary variable must be a local scalar that is knowable at
+ * compile time; anything else exceeds the complexity of the opcode. So
+ * discover what the index is.
+ */
+
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ name = varTokenPtr[1].start;
+ nameChars = varTokenPtr[1].size;
+ if (!TclIsLocalScalar(name, nameChars)) {
+ return TCL_ERROR;
+ }
+ dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
+
+ /*
+ * Remaining words (key path and value to set) can be handled normally.
+ */
+
+ tokenPtr = TokenAfter(varTokenPtr);
+ numWords = parsePtr->numWords-1;
+ for (i=1 ; i<numWords ; i++) {
+ CompileWord(envPtr, tokenPtr, interp, i);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+
+ /*
+ * Now emit the instruction to do the dict manipulation.
+ */
+
+ TclEmitInstInt4( INST_DICT_SET, numWords-2, envPtr);
+ TclEmitInt4( dictVarIndex, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileDictIncrCmd(
+ Tcl_Interp *interp, /* Used for looking up stuff. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Proc *procPtr = envPtr->procPtr;
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *varTokenPtr, *keyTokenPtr;
+ int dictVarIndex, nameChars, incrAmount;
+ const char *name;
+
+ /*
+ * There must be at least two arguments after the command.
+ */
+
+ if (parsePtr->numWords < 3 || parsePtr->numWords > 4 || procPtr == NULL) {
+ return TCL_ERROR;
+ }
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ keyTokenPtr = TokenAfter(varTokenPtr);
+
+ /*
+ * Parse the increment amount, if present.
+ */
+
+ if (parsePtr->numWords == 4) {
+ const char *word;
+ int numBytes, code;
+ Tcl_Token *incrTokenPtr;
+ Tcl_Obj *intObj;
+
+ incrTokenPtr = TokenAfter(keyTokenPtr);
+ if (incrTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ word = incrTokenPtr[1].start;
+ numBytes = incrTokenPtr[1].size;
+
+ intObj = Tcl_NewStringObj(word, numBytes);
+ Tcl_IncrRefCount(intObj);
+ code = TclGetIntFromObj(NULL, intObj, &incrAmount);
+ TclDecrRefCount(intObj);
+ if (code != TCL_OK) {
+ return TCL_ERROR;
+ }
+ } else {
+ incrAmount = 1;
+ }
+
+ /*
+ * The dictionary variable must be a local scalar that is knowable at
+ * compile time; anything else exceeds the complexity of the opcode. So
+ * discover what the index is.
+ */
+
+ if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ name = varTokenPtr[1].start;
+ nameChars = varTokenPtr[1].size;
+ if (!TclIsLocalScalar(name, nameChars)) {
+ return TCL_ERROR;
+ }
+ dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
+
+ /*
+ * Emit the key and the code to actually do the increment.
+ */
+
+ CompileWord(envPtr, keyTokenPtr, interp, 3);
+ TclEmitInstInt4( INST_DICT_INCR_IMM, incrAmount, envPtr);
+ TclEmitInt4( dictVarIndex, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileDictGetCmd(
+ Tcl_Interp *interp, /* Used for looking up stuff. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr;
+ int numWords, i;
+ DefineLineInformation; /* TIP #280 */
+
+ /*
+ * There must be at least two arguments after the command (the single-arg
+ * case is legal, but too special and magic for us to deal with here).
+ */
+
+ if (parsePtr->numWords < 3) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ numWords = parsePtr->numWords-1;
+
+ /*
+ * Only compile this because we need INST_DICT_GET anyway.
+ */
+
+ for (i=0 ; i<numWords ; i++) {
+ CompileWord(envPtr, tokenPtr, interp, i);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ TclEmitInstInt4(INST_DICT_GET, numWords-1, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileDictForCmd(
+ Tcl_Interp *interp, /* Used for looking up stuff. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Proc *procPtr = envPtr->procPtr;
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr;
+ int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange;
+ int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset;
+ int numVars, endTargetOffset;
+ int savedStackDepth = envPtr->currStackDepth;
+ /* Needed because jumps confuse the stack
+ * space calculator. */
+ const char **argv;
+ Tcl_DString buffer;
+
+ /*
+ * There must be at least three argument after the command.
+ */
+
+ if (parsePtr->numWords != 4 || procPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ varsTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ dictTokenPtr = TokenAfter(varsTokenPtr);
+ bodyTokenPtr = TokenAfter(dictTokenPtr);
+ if (varsTokenPtr->type != TCL_TOKEN_SIMPLE_WORD ||
+ bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Check we've got a pair of variables and that they are local variables.
+ * Then extract their indices in the LVT.
+ */
+
+ Tcl_DStringInit(&buffer);
+ Tcl_DStringAppend(&buffer, varsTokenPtr[1].start, varsTokenPtr[1].size);
+ if (Tcl_SplitList(NULL, Tcl_DStringValue(&buffer), &numVars,
+ &argv) != TCL_OK) {
+ Tcl_DStringFree(&buffer);
+ return TCL_ERROR;
+ }
+ Tcl_DStringFree(&buffer);
+ if (numVars != 2) {
+ ckfree((char *) argv);
+ return TCL_ERROR;
+ }
+
+ nameChars = strlen(argv[0]);
+ if (!TclIsLocalScalar(argv[0], nameChars)) {
+ ckfree((char *) argv);
+ return TCL_ERROR;
+ }
+ keyVarIndex = TclFindCompiledLocal(argv[0], nameChars, 1, procPtr);
+
+ nameChars = strlen(argv[1]);
+ if (!TclIsLocalScalar(argv[1], nameChars)) {
+ ckfree((char *) argv);
+ return TCL_ERROR;
+ }
+ valueVarIndex = TclFindCompiledLocal(argv[1], nameChars, 1, procPtr);
+ ckfree((char *) argv);
+
+ /*
+ * Allocate a temporary variable to store the iterator reference. The
+ * variable will contain a Tcl_DictSearch reference which will be
+ * allocated by INST_DICT_FIRST and disposed when the variable is unset
+ * (at which point it should also have been finished with).
+ */
+
+ infoIndex = TclFindCompiledLocal(NULL, 0, 1, procPtr);
+
+ /*
+ * Preparation complete; issue instructions. Note that this code issues
+ * fixed-sized jumps. That simplifies things a lot!
+ *
+ * First up, get the dictionary and start the iteration. No catching of
+ * errors at this point.
+ */
+
+ CompileWord(envPtr, dictTokenPtr, interp, 3);
+ TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr);
+ emptyTargetOffset = CurrentOffset(envPtr);
+ TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr);
+
+ /*
+ * Now we catch errors from here on so that we can finalize the search
+ * started by Tcl_DictObjFirst above.
+ */
+
+ catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+ TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr);
+ ExceptionRangeStarts(envPtr, catchRange);
+
+ /*
+ * Inside the iteration, write the loop variables.
+ */
+
+ bodyTargetOffset = CurrentOffset(envPtr);
+ TclEmitInstInt4( INST_STORE_SCALAR4, keyVarIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ TclEmitInstInt4( INST_STORE_SCALAR4, valueVarIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+
+ /*
+ * Set up the loop exception targets.
+ */
+
+ loopRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
+ ExceptionRangeStarts(envPtr, loopRange);
+
+ /*
+ * Compile the loop body itself. It should be stack-neutral.
+ */
+
+ SetLineInformation(3);
+ CompileBody(envPtr, bodyTokenPtr, interp);
+ TclEmitOpcode( INST_POP, envPtr);
+
+ /*
+ * Both exception target ranges (error and loop) end here.
+ */
+
+ ExceptionRangeEnds(envPtr, loopRange);
+ ExceptionRangeEnds(envPtr, catchRange);
+
+ /*
+ * Continue (or just normally process) by getting the next pair of items
+ * from the dictionary and jumping back to the code to write them into
+ * variables if there is another pair.
+ */
+
+ ExceptionRangeTarget(envPtr, loopRange, continueOffset);
+ TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr);
+ jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr);
+ TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+
+ /*
+ * Now do the final cleanup for the no-error case (this is where we break
+ * out of the loop to) by force-terminating the iteration (if not already
+ * terminated), ditching the exception info and jumping to the last
+ * instruction for this command. In theory, this could be done using the
+ * "finally" clause (next generated) but this is faster.
+ */
+
+ ExceptionRangeTarget(envPtr, loopRange, breakOffset);
+ TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
+ endTargetOffset = CurrentOffset(envPtr);
+ TclEmitInstInt4( INST_JUMP4, 0, envPtr);
+
+ /*
+ * Error handler "finally" clause, which force-terminates the iteration
+ * and rethrows the error.
+ */
+
+ ExceptionRangeTarget(envPtr, catchRange, catchOffset);
+ TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
+ TclEmitOpcode( INST_PUSH_RESULT, envPtr);
+ TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
+ TclEmitOpcode( INST_RETURN_STK, envPtr);
+
+ /*
+ * Otherwise we're done (the jump after the DICT_FIRST points here) and we
+ * need to pop the bogus key/value pair (pushed to keep stack calculations
+ * easy!) Note that we skip the END_CATCH. [Bug 1382528]
+ */
+
+ envPtr->currStackDepth = savedStackDepth+2;
+ jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset;
+ TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement,
+ envPtr->codeStart + emptyTargetOffset);
+ TclEmitOpcode( INST_POP, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr);
+
+ /*
+ * Final stage of the command (normal case) is that we push an empty
+ * object. This is done last to promote peephole optimization when it's
+ * dropped immediately.
+ */
+
+ jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset;
+ TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement,
+ envPtr->codeStart + endTargetOffset);
+ PushLiteral(envPtr, "", 0);
+ return TCL_OK;
+}
+
+int
+TclCompileDictUpdateCmd(
+ Tcl_Interp *interp, /* Used for looking up stuff. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Proc *procPtr = envPtr->procPtr;
+ DefineLineInformation; /* TIP #280 */
+ const char *name;
+ int i, nameChars, dictIndex, numVars, range, infoIndex;
+ Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr, *tokenPtr;
+ DictUpdateInfo *duiPtr;
+ JumpFixup jumpFixup;
+
+ /*
+ * There must be at least one argument after the command.
+ */
+
+ if (parsePtr->numWords < 5 || procPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Parse the command. Expect the following:
+ * dict update <lit(eral)> <any> <lit> ?<any> <lit> ...? <lit>
+ */
+
+ if ((parsePtr->numWords - 1) & 1) {
+ return TCL_ERROR;
+ }
+ numVars = (parsePtr->numWords - 3) / 2;
+
+ /*
+ * The dictionary variable must be a local scalar that is knowable at
+ * compile time; anything else exceeds the complexity of the opcode. So
+ * discover what the index is.
+ */
+
+ dictVarTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ if (dictVarTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ name = dictVarTokenPtr[1].start;
+ nameChars = dictVarTokenPtr[1].size;
+ if (!TclIsLocalScalar(name, nameChars)) {
+ return TCL_ERROR;
+ }
+ dictIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
+
+ /*
+ * Assemble the instruction metadata. This is complex enough that it is
+ * represented as auxData; it holds an ordered list of variable indices
+ * that are to be used.
+ */
+
+ duiPtr = (DictUpdateInfo *)
+ ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1));
+ duiPtr->length = numVars;
+ keyTokenPtrs = (Tcl_Token **) TclStackAlloc(interp,
+ sizeof(Tcl_Token *) * numVars);
+ tokenPtr = TokenAfter(dictVarTokenPtr);
+
+ for (i=0 ; i<numVars ; i++) {
+ /*
+ * Put keys to one side for later compilation to bytecode.
+ */
+
+ keyTokenPtrs[i] = tokenPtr;
+
+ /*
+ * Variables first need to be checked for sanity.
+ */
+
+ tokenPtr = TokenAfter(tokenPtr);
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ ckfree((char *) duiPtr);
+ TclStackFree(interp, keyTokenPtrs);
+ return TCL_ERROR;
+ }
+ name = tokenPtr[1].start;
+ nameChars = tokenPtr[1].size;
+ if (!TclIsLocalScalar(name, nameChars)) {
+ ckfree((char *) duiPtr);
+ TclStackFree(interp, keyTokenPtrs);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Stash the index in the auxiliary data.
+ */
+
+ duiPtr->varIndices[i] =
+ TclFindCompiledLocal(name, nameChars, 1, procPtr);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ ckfree((char *) duiPtr);
+ TclStackFree(interp, keyTokenPtrs);
+ return TCL_ERROR;
+ }
+ bodyTokenPtr = tokenPtr;
+
+ /*
+ * The list of variables to bind is stored in auxiliary data so that it
+ * can't be snagged by literal sharing and forced to shimmer dangerously.
+ */
+
+ infoIndex = TclCreateAuxData(duiPtr, &tclDictUpdateInfoType, envPtr);
+
+ for (i=0 ; i<numVars ; i++) {
+ CompileWord(envPtr, keyTokenPtrs[i], interp, i);
+ }
+ TclEmitInstInt4( INST_LIST, numVars, envPtr);
+ TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
+
+ range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+ TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
+
+ ExceptionRangeStarts(envPtr, range);
+ SetLineInformation(parsePtr->numWords - 1);
+ CompileBody(envPtr, bodyTokenPtr, interp);
+ ExceptionRangeEnds(envPtr, range);
+
+ /*
+ * Normal termination code: the stack has the key list below the result of
+ * the body evaluation: swap them and finish the update code.
+ */
+
+ TclEmitOpcode( INST_END_CATCH, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
+ TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
+
+ /*
+ * Jump around the exceptional termination code.
+ */
+
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
+
+ /*
+ * Termination code for non-ok returns: stash the result and return
+ * options in the stack, bring up the key list, finish the update code,
+ * and finally return with the catched return data
+ */
+
+ ExceptionRangeTarget(envPtr, range, catchOffset);
+ TclEmitOpcode( INST_PUSH_RESULT, envPtr);
+ TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 3, envPtr);
+
+ TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
+ TclEmitOpcode( INST_RETURN_STK, envPtr);
+
+ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
+ Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
+ (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
+ }
+ TclStackFree(interp, keyTokenPtrs);
+ return TCL_OK;
+}
+
+int
+TclCompileDictAppendCmd(
+ Tcl_Interp *interp, /* Used for looking up stuff. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Proc *procPtr = envPtr->procPtr;
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr;
+ int i, dictVarIndex;
+
+ /*
+ * There must be at least two argument after the command. And we impose an
+ * (arbirary) safe limit; anyone exceeding it should stop worrying about
+ * speed quite so much. ;-)
+ */
+
+ if (parsePtr->numWords<4 || parsePtr->numWords>100 || procPtr==NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the index of the local variable that we will be working with.
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ } else {
+ register const char *name = tokenPtr[1].start;
+ register int nameChars = tokenPtr[1].size;
+
+ if (!TclIsLocalScalar(name, nameChars)) {
+ return TCL_ERROR;
+ }
+ dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
+ }
+
+ /*
+ * Produce the string to concatenate onto the dictionary entry.
+ */
+
+ tokenPtr = TokenAfter(tokenPtr);
+ for (i=2 ; i<parsePtr->numWords ; i++) {
+ CompileWord(envPtr, tokenPtr, interp, i);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ if (parsePtr->numWords > 4) {
+ TclEmitInstInt1(INST_CONCAT1, parsePtr->numWords-3, envPtr);
+ }
+
+ /*
+ * Do the concatenation.
+ */
+
+ TclEmitInstInt4(INST_DICT_APPEND, dictVarIndex, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileDictLappendCmd(
+ Tcl_Interp *interp, /* Used for looking up stuff. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Proc *procPtr = envPtr->procPtr;
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *varTokenPtr, *keyTokenPtr, *valueTokenPtr;
+ int dictVarIndex, nameChars;
+ const char *name;
+
+ /*
+ * There must be three arguments after the command.
+ */
+
+ if (parsePtr->numWords != 4 || procPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ keyTokenPtr = TokenAfter(varTokenPtr);
+ valueTokenPtr = TokenAfter(keyTokenPtr);
+ if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ name = varTokenPtr[1].start;
+ nameChars = varTokenPtr[1].size;
+ if (!TclIsLocalScalar(name, nameChars)) {
+ return TCL_ERROR;
+ }
+ dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr);
+ CompileWord(envPtr, keyTokenPtr, interp, 3);
+ CompileWord(envPtr, valueTokenPtr, interp, 4);
+ TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupDictUpdateInfo, FreeDictUpdateInfo --
+ *
+ * Functions to duplicate, release and print the aux data created for use
+ * with the INST_DICT_UPDATE_START and INST_DICT_UPDATE_END instructions.
+ *
+ * Results:
+ * DupDictUpdateInfo: a copy of the auxiliary data
+ * FreeDictUpdateInfo: none
+ * PrintDictUpdateInfo: none
+ *
+ * Side effects:
+ * DupDictUpdateInfo: allocates memory
+ * FreeDictUpdateInfo: releases memory
+ * PrintDictUpdateInfo: none
+ *
+ *----------------------------------------------------------------------
+ */
+
+static ClientData
+DupDictUpdateInfo(
+ ClientData clientData)
+{
+ DictUpdateInfo *dui1Ptr, *dui2Ptr;
+ unsigned len;
+
+ dui1Ptr = clientData;
+ len = sizeof(DictUpdateInfo) + sizeof(int) * (dui1Ptr->length - 1);
+ dui2Ptr = (DictUpdateInfo *) ckalloc(len);
+ memcpy(dui2Ptr, dui1Ptr, len);
+ return dui2Ptr;
+}
+
+static void
+FreeDictUpdateInfo(
+ ClientData clientData)
+{
+ ckfree(clientData);
+}
+
+static void
+PrintDictUpdateInfo(
+ ClientData clientData,
+ Tcl_Obj *appendObj,
+ ByteCode *codePtr,
+ unsigned int pcOffset)
+{
+ DictUpdateInfo *duiPtr = clientData;
+ int i;
+
+ for (i=0 ; i<duiPtr->length ; i++) {
+ if (i) {
+ Tcl_AppendToObj(appendObj, ", ", -1);
+ }
+ Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompileExprCmd --
*
* Procedure called to compile the "expr" command.
*
* Results:
- * The return value is a standard Tcl result, which is TCL_OK
- * unless there was an error while parsing string. If an error occurs
- * then the interpreter's result contains a standard error message.
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
*
* Side effects:
- * Instructions are added to envPtr to execute the "expr" command
- * at runtime.
+ * Instructions are added to envPtr to execute the "expr" command at
+ * runtime.
*
*----------------------------------------------------------------------
*/
int
-TclCompileExprCmd(interp, parsePtr, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- Tcl_Parse *parsePtr; /* Points to a parse structure for the
- * command created by Tcl_ParseCommand. */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+TclCompileExprCmd(
+ 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 *firstWordPtr;
- DefineLineInformation;
-
if (parsePtr->numWords == 1) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"expr arg ?arg ...?\"", -1);
- return TCL_ERROR;
+ return TCL_ERROR;
}
- SetLineInformation (1);
- firstWordPtr = parsePtr->tokenPtr
- + (parsePtr->tokenPtr->numComponents + 1);
- return TclCompileExprWords(interp, firstWordPtr, (parsePtr->numWords-1),
- envPtr);
+ /*
+ * TIP #280: Use the per-word line information of the current command.
+ */
+
+ envPtr->line = envPtr->extCmdMapPtr->loc[
+ envPtr->extCmdMapPtr->nuloc-1].line[1];
+
+ firstWordPtr = TokenAfter(parsePtr->tokenPtr);
+ TclCompileExprWords(interp, firstWordPtr, parsePtr->numWords-1, envPtr);
+ return TCL_OK;
}
/*
@@ -516,36 +1432,33 @@ TclCompileExprCmd(interp, parsePtr, envPtr)
* Procedure called to compile the "for" command.
*
* Results:
- * The return value is a standard Tcl result, which is TCL_OK unless
- * there was an error while parsing string. If an error occurs then
- * the interpreter's result contains a standard error message.
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
*
* Side effects:
- * Instructions are added to envPtr to execute the "for" command
- * at runtime.
+ * Instructions are added to envPtr to execute the "for" command at
+ * runtime.
*
*----------------------------------------------------------------------
*/
+
int
-TclCompileForCmd(interp, parsePtr, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- Tcl_Parse *parsePtr; /* Points to a parse structure for the
- * command created by Tcl_ParseCommand. */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+TclCompileForCmd(
+ 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 *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;
JumpFixup jumpEvalCondFixup;
int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist;
- int bodyRange, nextRange, code;
- char buffer[32 + TCL_INTEGER_SPACE];
+ int bodyRange, nextRange;
int savedStackDepth = envPtr->currStackDepth;
-
- DefineLineInformation;
+ DefineLineInformation; /* TIP #280 */
if (parsePtr->numWords != 5) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"for start test next command\"", -1);
return TCL_ERROR;
}
@@ -555,11 +1468,10 @@ TclCompileForCmd(interp, parsePtr, envPtr)
* execute or execute forever, as in "for {} "$x > 5" {incr x} {}".
*/
- startTokenPtr = parsePtr->tokenPtr
- + (parsePtr->tokenPtr->numComponents + 1);
- testTokenPtr = startTokenPtr + (startTokenPtr->numComponents + 1);
+ startTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ testTokenPtr = TokenAfter(startTokenPtr);
if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_OUT_LINE_COMPILE;
+ return TCL_ERROR;
}
/*
@@ -567,23 +1479,20 @@ TclCompileForCmd(interp, parsePtr, envPtr)
* in order to insure correct behaviour [Bug 219166]
*/
- nextTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
- bodyTokenPtr = nextTokenPtr + (nextTokenPtr->numComponents + 1);
- if ((nextTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
+ nextTokenPtr = TokenAfter(testTokenPtr);
+ bodyTokenPtr = TokenAfter(nextTokenPtr);
+ if ((nextTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
|| (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
- return TCL_OUT_LINE_COMPILE;
+ return TCL_ERROR;
}
/*
- * Create ExceptionRange records for the body and the "next" command.
- * The "next" command's ExceptionRange supports break but not continue
- * (and has a -1 continueOffset).
+ * Create ExceptionRange records for the body and the "next" command. The
+ * "next" command's ExceptionRange supports break but not continue (and
+ * has a -1 continueOffset).
*/
- envPtr->exceptDepth++;
- envPtr->maxExceptDepth =
- TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
- bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
+ bodyRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
/*
@@ -591,17 +1500,9 @@ TclCompileForCmd(interp, parsePtr, envPtr)
*/
SetLineInformation (1);
- code = TclCompileCmdWord(interp, startTokenPtr+1,
- startTokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- if (code == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp,
- "\n (\"for\" initial command)", -1);
- }
- goto done;
- }
+ CompileBody(envPtr, startTokenPtr, interp);
TclEmitOpcode(INST_POP, envPtr);
-
+
/*
* Jump to the evaluation of the condition. This code uses the "loop
* rotation" optimisation (which eliminates one branch from the loop).
@@ -620,46 +1521,23 @@ TclCompileForCmd(interp, parsePtr, envPtr)
* Compile the loop body.
*/
- bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart);
-
+ bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange);
SetLineInformation (4);
- code = TclCompileCmdWord(interp, bodyTokenPtr+1,
- bodyTokenPtr->numComponents, envPtr);
+ CompileBody(envPtr, bodyTokenPtr, interp);
+ ExceptionRangeEnds(envPtr, bodyRange);
envPtr->currStackDepth = savedStackDepth + 1;
- if (code != TCL_OK) {
- if (code == TCL_ERROR) {
- sprintf(buffer, "\n (\"for\" body line %d)",
- interp->errorLine);
- Tcl_AddObjErrorInfo(interp, buffer, -1);
- }
- goto done;
- }
- envPtr->exceptArrayPtr[bodyRange].numCodeBytes =
- (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
TclEmitOpcode(INST_POP, envPtr);
-
/*
* Compile the "next" subcommand.
*/
- nextCodeOffset = (envPtr->codeNext - envPtr->codeStart);
-
- SetLineInformation (3);
envPtr->currStackDepth = savedStackDepth;
- code = TclCompileCmdWord(interp, nextTokenPtr+1,
- nextTokenPtr->numComponents, envPtr);
+ nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange);
+ SetLineInformation (3);
+ CompileBody(envPtr, nextTokenPtr, interp);
+ ExceptionRangeEnds(envPtr, nextRange);
envPtr->currStackDepth = savedStackDepth + 1;
- if (code != TCL_OK) {
- if (code == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp,
- "\n (\"for\" loop-end command)", -1);
- }
- goto done;
- }
- envPtr->exceptArrayPtr[nextRange].numCodeBytes =
- (envPtr->codeNext - envPtr->codeStart)
- - nextCodeOffset;
TclEmitOpcode(INST_POP, envPtr);
envPtr->currStackDepth = savedStackDepth;
@@ -668,7 +1546,7 @@ TclCompileForCmd(interp, parsePtr, envPtr)
* terminates the for.
*/
- testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
+ testCodeOffset = CurrentOffset(envPtr);
jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
@@ -676,27 +1554,22 @@ TclCompileForCmd(interp, parsePtr, envPtr)
nextCodeOffset += 3;
testCodeOffset += 3;
}
+
SetLineInformation (2);
envPtr->currStackDepth = savedStackDepth;
- code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
- if (code != TCL_OK) {
- if (code == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp,
- "\n (\"for\" test expression)", -1);
- }
- goto done;
- }
+ TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
envPtr->currStackDepth = savedStackDepth + 1;
-
- jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
+
+ jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
if (jumpDist > 127) {
TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
} else {
TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
}
-
+
/*
- * Set the loop's offsets and break target.
+ * Fix the starting points of the exception ranges (may have moved due to
+ * jump type modification) and set where the exceptions target.
*/
envPtr->exceptArrayPtr[bodyRange].codeOffset = bodyCodeOffset;
@@ -704,21 +1577,17 @@ TclCompileForCmd(interp, parsePtr, envPtr)
envPtr->exceptArrayPtr[nextRange].codeOffset = nextCodeOffset;
- envPtr->exceptArrayPtr[bodyRange].breakOffset =
- envPtr->exceptArrayPtr[nextRange].breakOffset =
- (envPtr->codeNext - envPtr->codeStart);
-
+ ExceptionRangeTarget(envPtr, bodyRange, breakOffset);
+ ExceptionRangeTarget(envPtr, nextRange, breakOffset);
+
/*
* The for command's result is an empty string.
*/
envPtr->currStackDepth = savedStackDepth;
- TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
- code = TCL_OK;
+ PushLiteral(envPtr, "", 0);
- done:
- envPtr->exceptDepth--;
- return code;
+ return TCL_OK;
}
/*
@@ -729,27 +1598,24 @@ TclCompileForCmd(interp, parsePtr, envPtr)
* Procedure called to compile the "foreach" command.
*
* Results:
- * The return value is a standard Tcl result, which is TCL_OK if
- * compilation was successful. If an error occurs then the
- * interpreter's result contains a standard error message and TCL_ERROR
- * is returned. If the command is too complex for TclCompileForeachCmd,
- * TCL_OUT_LINE_COMPILE is returned indicating that the foreach command
- * should be compiled "out of line" by emitting code to invoke its
- * command procedure at runtime.
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
*
* Side effects:
- * Instructions are added to envPtr to execute the "foreach" command
- * at runtime.
+ * Instructions are added to envPtr to execute the "foreach" command at
+ * runtime.
*
-n*----------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
int
-TclCompileForeachCmd(interp, parsePtr, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- Tcl_Parse *parsePtr; /* Points to a parse structure for the
- * command created by Tcl_ParseCommand. */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+TclCompileForeachCmd(
+ 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. */
{
Proc *procPtr = envPtr->procPtr;
ForeachInfo *infoPtr; /* Points to the structure describing this
@@ -762,28 +1628,19 @@ TclCompileForeachCmd(interp, parsePtr, envPtr)
Tcl_Token *tokenPtr, *bodyTokenPtr;
unsigned char *jumpPc;
JumpFixup jumpFalseFixup;
- int jumpDist, jumpBackDist, jumpBackOffset, infoIndex, range;
+ int jumpBackDist, jumpBackOffset, infoIndex, range, bodyIndex;
int numWords, numLists, numVars, loopIndex, tempVar, i, j, code;
- char buffer[32 + TCL_INTEGER_SPACE];
int savedStackDepth = envPtr->currStackDepth;
-
-#ifdef TCL_TIP280
- int bodyIndex;
-#endif
+ DefineLineInformation; /* TIP #280 */
/*
* We parse the variable list argument words and create two arrays:
- * varcList[i] is number of variables in i-th var list
- * varvList[i] points to array of var names in i-th var list
+ * varcList[i] is number of variables in i-th var list.
+ * varvList[i] points to array of var names in i-th var list.
*/
-#define STATIC_VAR_LIST_SIZE 5
- int varcListStaticSpace[STATIC_VAR_LIST_SIZE];
- CONST char **varvListStaticSpace[STATIC_VAR_LIST_SIZE];
- int *varcList = varcListStaticSpace;
- CONST char ***varvList = varvListStaticSpace;
-
- DefineLineInformation;
+ int *varcList;
+ const char ***varvList;
/*
* If the foreach command isn't in a procedure, don't compile it inline:
@@ -791,129 +1648,120 @@ TclCompileForeachCmd(interp, parsePtr, envPtr)
*/
if (procPtr == NULL) {
- return TCL_OUT_LINE_COMPILE;
+ return TCL_ERROR;
}
numWords = parsePtr->numWords;
if ((numWords < 4) || (numWords%2 != 0)) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"foreach varList list ?varList list ...? command\"", -1);
- return TCL_ERROR;
+ return TCL_ERROR;
}
/*
- * Bail out if the body requires substitutions
- * in order to insure correct behaviour [Bug 219166]
+ * Bail out if the body requires substitutions in order to insure correct
+ * behaviour. [Bug 219166]
*/
- for (i = 0, tokenPtr = parsePtr->tokenPtr;
- i < numWords-1;
- i++, tokenPtr += (tokenPtr->numComponents + 1)) {
+
+ for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; i++) {
+ tokenPtr = TokenAfter(tokenPtr);
}
bodyTokenPtr = tokenPtr;
if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_OUT_LINE_COMPILE;
+ return TCL_ERROR;
}
-#ifdef TCL_TIP280
+
bodyIndex = i-1;
-#endif
/*
* Allocate storage for the varcList and varvList arrays if necessary.
*/
numLists = (numWords - 2)/2;
- if (numLists > STATIC_VAR_LIST_SIZE) {
- varcList = (int *) ckalloc(numLists * sizeof(int));
- varvList = (CONST char ***) ckalloc(numLists * sizeof(CONST char **));
- }
- for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
- varcList[loopIndex] = 0;
- varvList[loopIndex] = NULL;
- }
-
- /*
- * Set the exception stack depth.
- */
-
- envPtr->exceptDepth++;
- envPtr->maxExceptDepth =
- TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
+ varcList = (int *) TclStackAlloc(interp, numLists * sizeof(int));
+ memset(varcList, 0, numLists * sizeof(int));
+ varvList = (const char ***) TclStackAlloc(interp,
+ numLists * sizeof(const char **));
+ memset((char*) varvList, 0, numLists * sizeof(const char **));
/*
- * Break up each var list and set the varcList and varvList arrays.
- * Don't compile the foreach inline if any var name needs substitutions
- * or isn't a scalar, or if any var list needs substitutions.
+ * Break up each var list and set the varcList and varvList arrays. Don't
+ * compile the foreach inline if any var name needs substitutions or isn't
+ * a scalar, or if any var list needs substitutions.
*/
loopIndex = 0;
for (i = 0, tokenPtr = parsePtr->tokenPtr;
i < numWords-1;
- i++, tokenPtr += (tokenPtr->numComponents + 1)) {
- if (i%2 == 1) {
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- code = TCL_OUT_LINE_COMPILE;
- goto done;
- } else {
- /* Lots of copying going on here. Need a ListObj wizard
- * to show a better way. */
-
- Tcl_DString varList;
-
- Tcl_DStringInit(&varList);
- Tcl_DStringAppend(&varList, tokenPtr[1].start,
- tokenPtr[1].size);
- code = Tcl_SplitList(interp, Tcl_DStringValue(&varList),
- &varcList[loopIndex], &varvList[loopIndex]);
- Tcl_DStringFree(&varList);
- if (code != TCL_OK) {
- goto done;
- }
- numVars = varcList[loopIndex];
+ i++, tokenPtr = TokenAfter(tokenPtr)) {
+ Tcl_DString varList;
- /*
- * If the variable list is empty, we can enter an infinite
- * loop when the interpreted version would not. Take care to
- * ensure this does not happen. [Bug 1671138]
- */
+ if (i%2 != 1) {
+ continue;
+ }
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ code = TCL_ERROR;
+ goto done;
+ }
- if (numVars == 0) {
- code = TCL_OUT_LINE_COMPILE;
- goto done;
- }
+ /*
+ * Lots of copying going on here. Need a ListObj wizard to show a
+ * better way.
+ */
- for (j = 0; j < numVars; j++) {
- CONST char *varName = varvList[loopIndex][j];
- if (!TclIsLocalScalar(varName, (int) strlen(varName))) {
- code = TCL_OUT_LINE_COMPILE;
- goto done;
- }
- }
+ Tcl_DStringInit(&varList);
+ Tcl_DStringAppend(&varList, tokenPtr[1].start, tokenPtr[1].size);
+ code = Tcl_SplitList(interp, Tcl_DStringValue(&varList),
+ &varcList[loopIndex], &varvList[loopIndex]);
+ Tcl_DStringFree(&varList);
+ if (code != TCL_OK) {
+ code = TCL_ERROR;
+ goto done;
+ }
+ numVars = varcList[loopIndex];
+
+ /*
+ * If the variable list is empty, we can enter an infinite loop when
+ * the interpreted version would not. Take care to ensure this does
+ * not happen. [Bug 1671138]
+ */
+
+ if (numVars == 0) {
+ code = TCL_ERROR;
+ goto done;
+ }
+
+ for (j = 0; j < numVars; j++) {
+ const char *varName = varvList[loopIndex][j];
+
+ if (!TclIsLocalScalar(varName, (int) strlen(varName))) {
+ code = TCL_ERROR;
+ goto done;
}
- loopIndex++;
}
+ loopIndex++;
}
/*
- * We will compile the foreach command.
- * Reserve (numLists + 1) temporary variables:
+ * We will compile the foreach command. Reserve (numLists + 1) temporary
+ * variables:
* - numLists temps to hold each value list
* - 1 temp for the loop counter (index of next element in each list)
+ *
* At this time we don't try to reuse temporaries; if there are two
* nonoverlapping foreach loops, they don't share any temps.
*/
+ code = TCL_OK;
firstValueTemp = -1;
for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
- /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);
+ /*create*/ 1, procPtr);
if (loopIndex == 0) {
firstValueTemp = tempVar;
}
}
loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
- /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);
-
+ /*create*/ 1, procPtr);
+
/*
* Create and initialize the ForeachInfo and ForeachVarList data
* structures describing this command. Then create a AuxData record
@@ -921,7 +1769,7 @@ TclCompileForeachCmd(interp, parsePtr, envPtr)
*/
infoPtr = (ForeachInfo *) ckalloc((unsigned)
- (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
+ sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *));
infoPtr->numLists = numLists;
infoPtr->firstValueTemp = firstValueTemp;
infoPtr->loopCtTemp = loopCtTemp;
@@ -929,36 +1777,36 @@ TclCompileForeachCmd(interp, parsePtr, envPtr)
ForeachVarList *varListPtr;
numVars = varcList[loopIndex];
varListPtr = (ForeachVarList *) ckalloc((unsigned)
- sizeof(ForeachVarList) + (numVars * sizeof(int)));
+ sizeof(ForeachVarList) + numVars*sizeof(int));
varListPtr->numVars = numVars;
for (j = 0; j < numVars; j++) {
- CONST char *varName = varvList[loopIndex][j];
+ const char *varName = varvList[loopIndex][j];
int nameChars = strlen(varName);
+
varListPtr->varIndexes[j] = TclFindCompiledLocal(varName,
- nameChars, /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);
+ nameChars, /*create*/ 1, procPtr);
}
infoPtr->varLists[loopIndex] = varListPtr;
}
- infoIndex = TclCreateAuxData((ClientData) infoPtr, &tclForeachInfoType, envPtr);
+ infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr);
+
+ /*
+ * Create an exception record to handle [break] and [continue].
+ */
+
+ range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
/*
* Evaluate then store each value list in the associated temporary.
*/
- range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
-
loopIndex = 0;
for (i = 0, tokenPtr = parsePtr->tokenPtr;
i < numWords-1;
- i++, tokenPtr += (tokenPtr->numComponents + 1)) {
+ i++, tokenPtr = TokenAfter(tokenPtr)) {
if ((i%2 == 0) && (i > 0)) {
SetLineInformation (i);
- code = TclCompileTokens(interp, tokenPtr+1,
- tokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- goto done;
- }
-
+ CompileTokens(envPtr, tokenPtr, interp);
tempVar = (firstValueTemp + loopIndex);
if (tempVar <= 255) {
TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr);
@@ -975,50 +1823,36 @@ TclCompileForeachCmd(interp, parsePtr, envPtr)
*/
TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);
-
+
/*
* Top of loop code: assign each loop variable and check whether
* to terminate the loop.
*/
- envPtr->exceptArrayPtr[range].continueOffset =
- (envPtr->codeNext - envPtr->codeStart);
+ ExceptionRangeTarget(envPtr, range, continueOffset);
TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
-
+
/*
* Inline compile the loop body.
*/
SetLineInformation (bodyIndex);
- envPtr->exceptArrayPtr[range].codeOffset =
- (envPtr->codeNext - envPtr->codeStart);
- code = TclCompileCmdWord(interp, bodyTokenPtr+1,
- bodyTokenPtr->numComponents, envPtr);
+ ExceptionRangeStarts(envPtr, range);
+ CompileBody(envPtr, bodyTokenPtr, interp);
+ ExceptionRangeEnds(envPtr, range);
envPtr->currStackDepth = savedStackDepth + 1;
- if (code != TCL_OK) {
- if (code == TCL_ERROR) {
- sprintf(buffer, "\n (\"foreach\" body line %d)",
- interp->errorLine);
- Tcl_AddObjErrorInfo(interp, buffer, -1);
- }
- goto done;
- }
- envPtr->exceptArrayPtr[range].numCodeBytes =
- (envPtr->codeNext - envPtr->codeStart)
- - envPtr->exceptArrayPtr[range].codeOffset;
TclEmitOpcode(INST_POP, envPtr);
-
+
/*
- * Jump back to the test at the top of the loop. Generate a 4 byte jump
- * if the distance to the test is > 120 bytes. This is conservative and
+ * Jump back to the test at the top of the loop. Generate a 4 byte jump if
+ * the distance to the test is > 120 bytes. This is conservative and
* ensures that we won't have to replace this jump if we later need to
* replace the ifFalse jump with a 4 byte jump.
*/
- jumpBackOffset = (envPtr->codeNext - envPtr->codeStart);
- jumpBackDist =
- (jumpBackOffset - envPtr->exceptArrayPtr[range].continueOffset);
+ jumpBackOffset = CurrentOffset(envPtr);
+ jumpBackDist = jumpBackOffset-envPtr->exceptArrayPtr[range].continueOffset;
if (jumpBackDist > 120) {
TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr);
} else {
@@ -1029,9 +1863,7 @@ TclCompileForeachCmd(interp, parsePtr, envPtr)
* Fix the target of the jump after the foreach_step test.
*/
- jumpDist = (envPtr->codeNext - envPtr->codeStart)
- - jumpFalseFixup.codeOffset;
- if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
+ if (TclFixupForwardJumpToHere(envPtr, &jumpFalseFixup, 127)) {
/*
* Update the loop body's starting PC offset since it moved down.
*/
@@ -1057,28 +1889,24 @@ TclCompileForeachCmd(interp, parsePtr, envPtr)
* Set the loop's break target.
*/
- envPtr->exceptArrayPtr[range].breakOffset =
- (envPtr->codeNext - envPtr->codeStart);
-
+ ExceptionRangeTarget(envPtr, range, breakOffset);
+
/*
* The foreach command's result is an empty string.
*/
envPtr->currStackDepth = savedStackDepth;
- TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
+ PushLiteral(envPtr, "", 0);
envPtr->currStackDepth = savedStackDepth + 1;
- done:
+ done:
for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
- if (varvList[loopIndex] != (CONST char **) NULL) {
+ if (varvList[loopIndex] != NULL) {
ckfree((char *) varvList[loopIndex]);
}
}
- if (varcList != varcListStaticSpace) {
- ckfree((char *) varcList);
- ckfree((char *) varvList);
- }
- envPtr->exceptDepth--;
+ TclStackFree(interp, (void *)varvList);
+ TclStackFree(interp, varcList);
return code;
}
@@ -1087,8 +1915,8 @@ TclCompileForeachCmd(interp, parsePtr, envPtr)
*
* DupForeachInfo --
*
- * This procedure duplicates a ForeachInfo structure created as
- * auxiliary data during the compilation of a foreach command.
+ * This procedure duplicates a ForeachInfo structure created as auxiliary
+ * data during the compilation of a foreach command.
*
* Results:
* A pointer to a newly allocated copy of the existing ForeachInfo
@@ -1096,42 +1924,41 @@ TclCompileForeachCmd(interp, parsePtr, envPtr)
*
* Side effects:
* Storage for the copied ForeachInfo record is allocated. If the
- * original ForeachInfo structure pointed to any ForeachVarList
- * records, these structures are also copied and pointers to them
- * are stored in the new ForeachInfo record.
+ * original ForeachInfo structure pointed to any ForeachVarList records,
+ * these structures are also copied and pointers to them are stored in
+ * the new ForeachInfo record.
*
*----------------------------------------------------------------------
*/
static ClientData
-DupForeachInfo(clientData)
- ClientData clientData; /* The foreach command's compilation
- * auxiliary data to duplicate. */
+DupForeachInfo(
+ ClientData clientData) /* The foreach command's compilation auxiliary
+ * data to duplicate. */
{
- register ForeachInfo *srcPtr = (ForeachInfo *) clientData;
+ register ForeachInfo *srcPtr = clientData;
ForeachInfo *dupPtr;
register ForeachVarList *srcListPtr, *dupListPtr;
- int numLists = srcPtr->numLists;
- int numVars, i, j;
-
+ int numVars, i, j, numLists = srcPtr->numLists;
+
dupPtr = (ForeachInfo *) ckalloc((unsigned)
- (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
+ sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *));
dupPtr->numLists = numLists;
dupPtr->firstValueTemp = srcPtr->firstValueTemp;
dupPtr->loopCtTemp = srcPtr->loopCtTemp;
-
+
for (i = 0; i < numLists; i++) {
srcListPtr = srcPtr->varLists[i];
numVars = srcListPtr->numVars;
dupListPtr = (ForeachVarList *) ckalloc((unsigned)
- sizeof(ForeachVarList) + numVars*sizeof(int));
+ sizeof(ForeachVarList) + numVars*sizeof(int));
dupListPtr->numVars = numVars;
for (j = 0; j < numVars; j++) {
dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j];
}
dupPtr->varLists[i] = dupListPtr;
}
- return (ClientData) dupPtr;
+ return dupPtr;
}
/*
@@ -1154,11 +1981,11 @@ DupForeachInfo(clientData)
*/
static void
-FreeForeachInfo(clientData)
- ClientData clientData; /* The foreach command's compilation
- * auxiliary data to free. */
+FreeForeachInfo(
+ ClientData clientData) /* The foreach command's compilation auxiliary
+ * data to free. */
{
- register ForeachInfo *infoPtr = (ForeachInfo *) clientData;
+ register ForeachInfo *infoPtr = clientData;
register ForeachVarList *listPtr;
int numLists = infoPtr->numLists;
register int i;
@@ -1173,58 +2000,111 @@ FreeForeachInfo(clientData)
/*
*----------------------------------------------------------------------
*
+ * PrintForeachInfo --
+ *
+ * Function to write a human-readable representation of a ForeachInfo
+ * structure to stdout for debugging.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+PrintForeachInfo(
+ ClientData clientData,
+ Tcl_Obj *appendObj,
+ ByteCode *codePtr,
+ unsigned int pcOffset)
+{
+ register ForeachInfo *infoPtr = clientData;
+ register ForeachVarList *varsPtr;
+ int i, j;
+
+ Tcl_AppendToObj(appendObj, "data=[", -1);
+
+ for (i=0 ; i<infoPtr->numLists ; i++) {
+ if (i) {
+ Tcl_AppendToObj(appendObj, ", ", -1);
+ }
+ Tcl_AppendPrintfToObj(appendObj, "%%v%u",
+ (unsigned) (infoPtr->firstValueTemp + i));
+ }
+ Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%u",
+ (unsigned) infoPtr->loopCtTemp);
+ for (i=0 ; i<infoPtr->numLists ; i++) {
+ if (i) {
+ Tcl_AppendToObj(appendObj, ",", -1);
+ }
+ Tcl_AppendPrintfToObj(appendObj, "\n\t\t it%%v%u\t[",
+ (unsigned) (infoPtr->firstValueTemp + i));
+ varsPtr = infoPtr->varLists[i];
+ for (j=0 ; j<varsPtr->numVars ; j++) {
+ if (j) {
+ Tcl_AppendToObj(appendObj, ", ", -1);
+ }
+ Tcl_AppendPrintfToObj(appendObj, "%%v%u",
+ (unsigned) varsPtr->varIndexes[j]);
+ }
+ Tcl_AppendToObj(appendObj, "]", -1);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompileIfCmd --
*
* Procedure called to compile the "if" command.
*
* Results:
- * The return value is a standard Tcl result, which is TCL_OK if
- * compilation was successful. If an error occurs then the
- * interpreter's result contains a standard error message and TCL_ERROR
- * is returned. If the command is too complex for TclCompileIfCmd,
- * TCL_OUT_LINE_COMPILE is returned indicating that the if command
- * should be compiled "out of line" by emitting code to invoke its
- * command procedure at runtime.
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
*
* Side effects:
- * Instructions are added to envPtr to execute the "if" command
- * at runtime.
+ * Instructions are added to envPtr to execute the "if" command at
+ * runtime.
*
*----------------------------------------------------------------------
*/
+
int
-TclCompileIfCmd(interp, parsePtr, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- Tcl_Parse *parsePtr; /* Points to a parse structure for the
- * command created by Tcl_ParseCommand. */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+TclCompileIfCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
{
JumpFixupArray jumpFalseFixupArray;
/* Used to fix the ifFalse jump after each
* test when its target PC is determined. */
JumpFixupArray jumpEndFixupArray;
- /* Used to fix the jump after each "then"
- * body to the end of the "if" when that PC
- * is determined. */
+ /* Used to fix the jump after each "then" body
+ * to the end of the "if" when that PC is
+ * determined. */
Tcl_Token *tokenPtr, *testTokenPtr;
- int jumpDist, jumpFalseDist;
- int jumpIndex = 0; /* avoid compiler warning. */
- int numWords, wordIdx, numBytes, j, code;
- CONST char *word;
- char buffer[100];
+ int jumpIndex = 0; /* Avoid compiler warning. */
+ int jumpFalseDist, numWords, wordIdx, numBytes, j, code;
+ const char *word;
int savedStackDepth = envPtr->currStackDepth;
- /* Saved stack depth at the start of the first
+ /* Saved stack depth at the start of the first
* test; the envPtr current depth is restored
* to this value at the start of each test. */
- int realCond = 1; /* set to 0 for static conditions: "if 0 {..}" */
- int boolVal; /* value of static condition */
- int compileScripts = 1;
-
- DefineLineInformation;
+ int realCond = 1; /* Set to 0 for static conditions:
+ * "if 0 {..}" */
+ int boolVal; /* Value of static condition. */
+ int compileScripts = 1;
+ DefineLineInformation; /* TIP #280 */
/*
- * Only compile the "if" command if all arguments are simple
- * words, in order to insure correct substitution [Bug 219166]
+ * Only compile the "if" command if all arguments are simple words, in
+ * order to insure correct substitution [Bug 219166]
*/
tokenPtr = parsePtr->tokenPtr;
@@ -1233,19 +2113,18 @@ TclCompileIfCmd(interp, parsePtr, envPtr)
for (wordIdx = 0; wordIdx < numWords; wordIdx++) {
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_OUT_LINE_COMPILE;
+ return TCL_ERROR;
}
- tokenPtr += 2;
+ tokenPtr = TokenAfter(tokenPtr);
}
-
TclInitJumpFixupArray(&jumpFalseFixupArray);
TclInitJumpFixupArray(&jumpEndFixupArray);
code = TCL_OK;
/*
- * Each iteration of this loop compiles one "if expr ?then? body"
- * or "elseif expr ?then? body" clause.
+ * Each iteration of this loop compiles one "if expr ?then? body" or
+ * "elseif expr ?then? body" clause.
*/
tokenPtr = parsePtr->tokenPtr;
@@ -1258,84 +2137,66 @@ TclCompileIfCmd(interp, parsePtr, envPtr)
word = tokenPtr[1].start;
numBytes = tokenPtr[1].size;
if ((tokenPtr == parsePtr->tokenPtr)
- || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) {
- tokenPtr += (tokenPtr->numComponents + 1);
+ || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) {
+ tokenPtr = TokenAfter(tokenPtr);
wordIdx++;
} else {
break;
}
if (wordIdx >= numWords) {
- sprintf(buffer,
- "wrong # args: no expression after \"%.*s\" argument",
- (numBytes > 50 ? 50 : numBytes), word);
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1);
code = TCL_ERROR;
goto done;
}
/*
- * Compile the test expression then emit the conditional jump
- * around the "then" part.
+ * Compile the test expression then emit the conditional jump around
+ * the "then" part.
*/
-
+
envPtr->currStackDepth = savedStackDepth;
testTokenPtr = tokenPtr;
-
if (realCond) {
/*
- * Find out if the condition is a constant.
+ * Find out if the condition is a constant.
*/
-
+
Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start,
testTokenPtr[1].size);
Tcl_IncrRefCount(boolObj);
code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
- Tcl_DecrRefCount(boolObj);
+ TclDecrRefCount(boolObj);
if (code == TCL_OK) {
/*
- * A static condition
+ * A static condition.
*/
+
realCond = 0;
if (!boolVal) {
compileScripts = 0;
}
} else {
- Tcl_ResetResult(interp);
SetLineInformation (wordIdx);
- code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
- if (code != TCL_OK) {
- if (code == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp,
- "\n (\"if\" test expression)", -1);
- }
- goto done;
- }
+ Tcl_ResetResult(interp);
+ TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
TclExpandJumpFixupArray(&jumpFalseFixupArray);
}
jumpIndex = jumpFalseFixupArray.next;
jumpFalseFixupArray.next++;
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
- &(jumpFalseFixupArray.fixup[jumpIndex]));
+ jumpFalseFixupArray.fixup+jumpIndex);
}
+ code = TCL_OK;
}
-
/*
* Skip over the optional "then" before the then clause.
*/
- tokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
+ tokenPtr = TokenAfter(testTokenPtr);
wordIdx++;
if (wordIdx >= numWords) {
- sprintf(buffer,
- "wrong # args: no script following \"%.*s\" argument",
- (testTokenPtr->size > 50 ? 50 : testTokenPtr->size),
- testTokenPtr->start);
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1);
code = TCL_ERROR;
goto done;
}
@@ -1343,12 +2204,9 @@ TclCompileIfCmd(interp, parsePtr, envPtr)
word = tokenPtr[1].start;
numBytes = tokenPtr[1].size;
if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) {
- tokenPtr += (tokenPtr->numComponents + 1);
+ tokenPtr = TokenAfter(tokenPtr);
wordIdx++;
if (wordIdx >= numWords) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: no script following \"then\" argument", -1);
code = TCL_ERROR;
goto done;
}
@@ -1362,85 +2220,72 @@ TclCompileIfCmd(interp, parsePtr, envPtr)
if (compileScripts) {
SetLineInformation (wordIdx);
envPtr->currStackDepth = savedStackDepth;
- code = TclCompileCmdWord(interp, tokenPtr+1,
- tokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- if (code == TCL_ERROR) {
- sprintf(buffer, "\n (\"if\" then script line %d)",
- interp->errorLine);
- Tcl_AddObjErrorInfo(interp, buffer, -1);
- }
- goto done;
- }
+ CompileBody(envPtr, tokenPtr, interp);
}
if (realCond) {
/*
- * Jump to the end of the "if" command. Both jumpFalseFixupArray and
- * jumpEndFixupArray are indexed by "jumpIndex".
+ * Jump to the end of the "if" command. Both jumpFalseFixupArray
+ * and jumpEndFixupArray are indexed by "jumpIndex".
*/
-
+
if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {
TclExpandJumpFixupArray(&jumpEndFixupArray);
}
jumpEndFixupArray.next++;
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
- &(jumpEndFixupArray.fixup[jumpIndex]));
-
+ jumpEndFixupArray.fixup+jumpIndex);
+
/*
- * Fix the target of the jumpFalse after the test. Generate a 4 byte
- * jump if the distance is > 120 bytes. This is conservative, and
- * ensures that we won't have to replace this jump if we later also
- * need to replace the proceeding jump to the end of the "if" with a
- * 4 byte jump.
+ * Fix the target of the jumpFalse after the test. Generate a 4
+ * byte jump if the distance is > 120 bytes. This is conservative,
+ * and ensures that we won't have to replace this jump if we later
+ * also need to replace the proceeding jump to the end of the "if"
+ * with a 4 byte jump.
*/
- jumpDist = (envPtr->codeNext - envPtr->codeStart)
- - jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
- if (TclFixupForwardJump(envPtr,
- &(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) {
+ if (TclFixupForwardJumpToHere(envPtr,
+ jumpFalseFixupArray.fixup+jumpIndex, 120)) {
/*
* Adjust the code offset for the proceeding jump to the end
* of the "if" command.
*/
-
+
jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
}
} else if (boolVal) {
- /*
- *We were processing an "if 1 {...}"; stop compiling
- * scripts
+ /*
+ * We were processing an "if 1 {...}"; stop compiling scripts.
*/
compileScripts = 0;
} else {
- /*
- *We were processing an "if 0 {...}"; reset so that
- * the rest (elseif, else) is compiled correctly
+ /*
+ * We were processing an "if 0 {...}"; reset so that the rest
+ * (elseif, else) is compiled correctly.
*/
realCond = 1;
compileScripts = 1;
- }
+ }
- tokenPtr += (tokenPtr->numComponents + 1);
+ tokenPtr = TokenAfter(tokenPtr);
wordIdx++;
}
/*
- * Restore the current stack depth in the environment; the
- * "else" clause (or its default) will add 1 to this.
+ * Restore the current stack depth in the environment; the "else" clause
+ * (or its default) will add 1 to this.
*/
envPtr->currStackDepth = savedStackDepth;
/*
- * Check for the optional else clause. Do not compile
- * anything if this was an "if 1 {...}" case.
+ * Check for the optional else clause. Do not compile anything if this was
+ * an "if 1 {...}" case.
*/
- if ((wordIdx < numWords)
- && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
+ if ((wordIdx < numWords) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
/*
* There is an else clause. Skip over the optional "else" word.
*/
@@ -1448,12 +2293,9 @@ TclCompileIfCmd(interp, parsePtr, envPtr)
word = tokenPtr[1].start;
numBytes = tokenPtr[1].size;
if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) {
- tokenPtr += (tokenPtr->numComponents + 1);
+ tokenPtr = TokenAfter(tokenPtr);
wordIdx++;
if (wordIdx >= numWords) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: no script following \"else\" argument", -1);
code = TCL_ERROR;
goto done;
}
@@ -1463,28 +2305,17 @@ TclCompileIfCmd(interp, parsePtr, envPtr)
/*
* Compile the else command body.
*/
+
SetLineInformation (wordIdx);
- code = TclCompileCmdWord(interp, tokenPtr+1,
- tokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- if (code == TCL_ERROR) {
- sprintf(buffer, "\n (\"if\" else script line %d)",
- interp->errorLine);
- Tcl_AddObjErrorInfo(interp, buffer, -1);
- }
- goto done;
- }
+ CompileBody(envPtr, tokenPtr, interp);
}
/*
* Make sure there are no words after the else clause.
*/
-
+
wordIdx++;
if (wordIdx < numWords) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: extra words after \"else\" clause in \"if\" command", -1);
code = TCL_ERROR;
goto done;
}
@@ -1494,28 +2325,27 @@ TclCompileIfCmd(interp, parsePtr, envPtr)
*/
if (compileScripts) {
- TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
+ PushLiteral(envPtr, "", 0);
}
}
/*
* Fix the unconditional jumps to the end of the "if" command.
*/
-
+
for (j = jumpEndFixupArray.next; j > 0; j--) {
- jumpIndex = (j - 1); /* i.e. process the closest jump first */
- jumpDist = (envPtr->codeNext - envPtr->codeStart)
- - jumpEndFixupArray.fixup[jumpIndex].codeOffset;
- if (TclFixupForwardJump(envPtr,
- &(jumpEndFixupArray.fixup[jumpIndex]), jumpDist, 127)) {
+ jumpIndex = (j - 1); /* i.e. process the closest jump first. */
+ if (TclFixupForwardJumpToHere(envPtr,
+ jumpEndFixupArray.fixup+jumpIndex, 127)) {
/*
- * Adjust the immediately preceeding "ifFalse" jump. We moved
- * it's target (just after this jump) down three bytes.
+ * Adjust the immediately preceeding "ifFalse" jump. We moved it's
+ * target (just after this jump) down three bytes.
*/
unsigned char *ifFalsePc = envPtr->codeStart
- + jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
+ + jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
unsigned char opCode = *ifFalsePc;
+
if (opCode == INST_JUMP_FALSE1) {
jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1);
jumpFalseDist += 3;
@@ -1525,7 +2355,7 @@ TclCompileIfCmd(interp, parsePtr, envPtr)
jumpFalseDist += 3;
TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
} else {
- panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump");
+ Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode);
}
}
}
@@ -1534,7 +2364,7 @@ TclCompileIfCmd(interp, parsePtr, envPtr)
* Free the jumpFixupArray array if malloc'ed storage was used.
*/
- done:
+ done:
envPtr->currStackDepth = savedStackDepth + 1;
TclFreeJumpFixupArray(&jumpFalseFixupArray);
TclFreeJumpFixupArray(&jumpEndFixupArray);
@@ -1549,50 +2379,37 @@ TclCompileIfCmd(interp, parsePtr, envPtr)
* Procedure called to compile the "incr" command.
*
* Results:
- * The return value is a standard Tcl result, which is TCL_OK if
- * compilation was successful. If an error occurs then the
- * interpreter's result contains a standard error message and TCL_ERROR
- * is returned. If the command is too complex for TclCompileIncrCmd,
- * TCL_OUT_LINE_COMPILE is returned indicating that the incr command
- * should be compiled "out of line" by emitting code to invoke its
- * command procedure at runtime.
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
*
* Side effects:
- * Instructions are added to envPtr to execute the "incr" command
- * at runtime.
+ * Instructions are added to envPtr to execute the "incr" command at
+ * runtime.
*
*----------------------------------------------------------------------
*/
int
-TclCompileIncrCmd(interp, parsePtr, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- Tcl_Parse *parsePtr; /* Points to a parse structure for the
- * command created by Tcl_ParseCommand. */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+TclCompileIncrCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *incrTokenPtr;
int simpleVarName, isScalar, localIndex, haveImmValue, immValue;
- int code = TCL_OK;
-
- DefineLineInformation;
+ DefineLineInformation; /* TIP #280 */
if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"incr varName ?increment?\"", -1);
return TCL_ERROR;
}
- varTokenPtr = parsePtr->tokenPtr
- + (parsePtr->tokenPtr->numComponents + 1);
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- code = TclPushVarNameWord(interp, varTokenPtr, envPtr,
- (TCL_NO_LARGE_INDEX | TCL_CREATE_VAR),
- &localIndex, &simpleVarName, &isScalar, 1);
- if (code != TCL_OK) {
- goto done;
- }
+ PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX|TCL_CREATE_VAR,
+ &localIndex, &simpleVarName, &isScalar, 1);
/*
* If an increment is given, push it, but see first if it's a small
@@ -1602,44 +2419,29 @@ TclCompileIncrCmd(interp, parsePtr, envPtr)
haveImmValue = 0;
immValue = 1;
if (parsePtr->numWords == 3) {
- incrTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
+ incrTokenPtr = TokenAfter(varTokenPtr);
if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- CONST char *word = incrTokenPtr[1].start;
+ const char *word = incrTokenPtr[1].start;
int numBytes = incrTokenPtr[1].size;
-
- /*
- * Note there is a danger that modifying the string could have
- * undesirable side effects. In this case, TclLooksLikeInt has
- * no dependencies on shared strings so we should be safe.
- */
-
- if (TclLooksLikeInt(word, numBytes)) {
- int code;
- Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes);
- Tcl_IncrRefCount(intObj);
- code = Tcl_GetIntFromObj(NULL, intObj, &immValue);
- Tcl_DecrRefCount(intObj);
- if ((code == TCL_OK)
- && (-127 <= immValue) && (immValue <= 127)) {
- haveImmValue = 1;
- }
+ int code;
+ Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes);
+ Tcl_IncrRefCount(intObj);
+ code = TclGetIntFromObj(NULL, intObj, &immValue);
+ TclDecrRefCount(intObj);
+ if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) {
+ haveImmValue = 1;
}
if (!haveImmValue) {
- TclEmitPush(
- TclRegisterNewLiteral(envPtr, word, numBytes), envPtr);
+ PushLiteral(envPtr, word, numBytes);
}
} else {
SetLineInformation (2);
- code = TclCompileTokens(interp, incrTokenPtr+1,
- incrTokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- goto done;
- }
+ CompileTokens(envPtr, incrTokenPtr, interp);
}
- } else { /* no incr amount given so use 1 */
+ } else { /* No incr amount given so use 1. */
haveImmValue = 1;
}
-
+
/*
* Emit the instruction to increment the variable.
*/
@@ -1676,16 +2478,15 @@ TclCompileIncrCmd(interp, parsePtr, envPtr)
}
}
}
- } else { /* non-simple variable name */
+ } else { /* Non-simple variable name. */
if (haveImmValue) {
TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr);
} else {
TclEmitOpcode(INST_INCR_STK, envPtr);
}
}
-
- done:
- return code;
+
+ return TCL_OK;
}
/*
@@ -1696,53 +2497,47 @@ TclCompileIncrCmd(interp, parsePtr, envPtr)
* Procedure called to compile the "lappend" command.
*
* Results:
- * The return value is a standard Tcl result, which is normally TCL_OK
- * unless there was an error while parsing string. If an error occurs
- * then the interpreter's result contains a standard error message. If
- * compilation fails because the command requires a second level of
- * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
- * command should be compiled "out of line" by emitting code to
- * invoke its command procedure (Tcl_LappendObjCmd) at runtime.
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
*
* Side effects:
- * Instructions are added to envPtr to execute the "lappend" command
- * at runtime.
+ * Instructions are added to envPtr to execute the "lappend" command at
+ * runtime.
*
*----------------------------------------------------------------------
*/
int
-TclCompileLappendCmd(interp, parsePtr, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- Tcl_Parse *parsePtr; /* Points to a parse structure for the
- * command created by Tcl_ParseCommand. */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+TclCompileLappendCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
{
- Tcl_Token *varTokenPtr, *valueTokenPtr;
+ Tcl_Token *varTokenPtr;
int simpleVarName, isScalar, localIndex, numWords;
- int code = TCL_OK;
-
- DefineLineInformation;
+ DefineLineInformation; /* TIP #280 */
/*
* If we're not in a procedure, don't compile.
*/
+
if (envPtr->procPtr == NULL) {
- return TCL_OUT_LINE_COMPILE;
+ return TCL_ERROR;
}
numWords = parsePtr->numWords;
if (numWords == 1) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"lappend varName ?value value ...?\"", -1);
return TCL_ERROR;
}
if (numWords != 3) {
/*
- * LAPPEND instructions currently only handle one value appends
+ * LAPPEND instructions currently only handle one value appends.
*/
- return TCL_OUT_LINE_COMPILE;
+
+ return TCL_ERROR;
}
/*
@@ -1750,36 +2545,22 @@ TclCompileLappendCmd(interp, parsePtr, envPtr)
* 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.
+ * namespace qualifiers.
*/
- varTokenPtr = parsePtr->tokenPtr
- + (parsePtr->tokenPtr->numComponents + 1);
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- code = TclPushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
- &localIndex, &simpleVarName, &isScalar, 1);
- if (code != TCL_OK) {
- goto done;
- }
+ PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
+ &localIndex, &simpleVarName, &isScalar, 1);
/*
- * If we are doing an assignment, push the new value.
- * In the no values case, create an empty object.
+ * If we are doing an assignment, push the new value. In the no values
+ * case, create an empty object.
*/
if (numWords > 2) {
- valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
- if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- TclEmitPush(TclRegisterNewLiteral(envPtr,
- valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
- } else {
- SetLineInformation (2);
- code = TclCompileTokens(interp, valueTokenPtr+1,
- valueTokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- goto done;
- }
- }
+ Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr);
+ CompileWord(envPtr, valueTokenPtr, interp, 2);
}
/*
@@ -1790,112 +2571,239 @@ TclCompileLappendCmd(interp, parsePtr, envPtr)
* The *_STK opcodes should be refactored to make better use of existing
* LOAD/STORE instructions.
*/
+
if (simpleVarName) {
if (isScalar) {
- if (localIndex >= 0) {
- if (localIndex <= 255) {
- TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr);
- }
- } else {
+ if (localIndex < 0) {
TclEmitOpcode(INST_LAPPEND_STK, envPtr);
+ } else if (localIndex <= 255) {
+ TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr);
+ } else {
+ TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr);
}
} else {
- if (localIndex >= 0) {
- if (localIndex <= 255) {
- TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr);
- } else {
- TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr);
- }
- } else {
+ if (localIndex < 0) {
TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr);
+ } else if (localIndex <= 255) {
+ TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr);
+ } else {
+ TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr);
}
}
} else {
TclEmitOpcode(INST_LAPPEND_STK, envPtr);
}
- done:
- return code;
+ return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * TclCompileLindexCmd --
+ * TclCompileLassignCmd --
*
- * Procedure called to compile the "lindex" command.
+ * Procedure called to compile the "lassign" command.
*
* Results:
- * The return value is a standard Tcl result, which is TCL_OK if the
- * compilation was successful. If the command cannot be byte-compiled,
- * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the
- * interpreter's result contains an error message, and TCL_ERROR is
- * returned.
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
*
* Side effects:
- * Instructions are added to envPtr to execute the "lindex" command
- * at runtime.
+ * Instructions are added to envPtr to execute the "lassign" command at
+ * runtime.
*
*----------------------------------------------------------------------
*/
int
-TclCompileLindexCmd(interp, parsePtr, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- Tcl_Parse *parsePtr; /* Points to a parse structure for the
- * command created by Tcl_ParseCommand. */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+TclCompileLassignCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
{
- Tcl_Token *varTokenPtr;
- int code, i;
- int numWords;
-
- DefineLineInformation;
+ Tcl_Token *tokenPtr;
+ int simpleVarName, isScalar, localIndex, numWords, idx;
+ DefineLineInformation; /* TIP #280 */
numWords = parsePtr->numWords;
/*
- * Quit if too few args
+ * Check for command syntax error, but we'll punt that to runtime.
*/
- if ( numWords <= 1 ) {
- return TCL_OUT_LINE_COMPILE;
+ if (numWords < 3) {
+ return TCL_ERROR;
}
- varTokenPtr = parsePtr->tokenPtr
- + (parsePtr->tokenPtr->numComponents + 1);
-
/*
- * Push the operands onto the stack.
+ * Generate code to push list being taken apart by [lassign].
*/
-
- for ( i = 1 ; i < numWords ; i++ ) {
- if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- TclEmitPush(
- TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
- varTokenPtr[1].size), envPtr);
- } else {
- SetLineInformation (i);
- code = TclCompileTokens(interp, varTokenPtr+1,
- varTokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- return code;
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+
+ /*
+ * Generate code to assign values from the list to variables.
+ */
+
+ for (idx=0 ; idx<numWords-2 ; idx++) {
+ tokenPtr = TokenAfter(tokenPtr);
+
+ /*
+ * Generate the next variable name.
+ */
+
+ PushVarNameWord(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex,
+ &simpleVarName, &isScalar, idx+2);
+
+ /*
+ * Emit instructions to get the idx'th item out of the list value on
+ * the stack and assign it to the variable.
+ */
+
+ if (simpleVarName) {
+ if (isScalar) {
+ if (localIndex >= 0) {
+ TclEmitOpcode(INST_DUP, envPtr);
+ TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
+ if (localIndex <= 255) {
+ TclEmitInstInt1(INST_STORE_SCALAR1,localIndex,envPtr);
+ } else {
+ TclEmitInstInt4(INST_STORE_SCALAR4,localIndex,envPtr);
+ }
+ } else {
+ TclEmitInstInt4(INST_OVER, 1, envPtr);
+ TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
+ TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr);
+ }
+ } else {
+ if (localIndex >= 0) {
+ TclEmitInstInt4(INST_OVER, 1, envPtr);
+ TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
+ if (localIndex <= 255) {
+ TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr);
+ } else {
+ TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr);
+ }
+ } else {
+ TclEmitInstInt4(INST_OVER, 2, envPtr);
+ TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
+ TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr);
+ }
}
+ } else {
+ TclEmitInstInt4(INST_OVER, 1, envPtr);
+ TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
+ TclEmitOpcode(INST_STORE_STK, envPtr);
}
- varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
+ TclEmitOpcode(INST_POP, envPtr);
}
-
+
/*
- * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI
- * if there are multiple index args.
+ * Generate code to leave the rest of the list on the stack.
*/
- if ( numWords == 3 ) {
- TclEmitOpcode( INST_LIST_INDEX, envPtr );
+ TclEmitInstInt4(INST_LIST_RANGE_IMM, idx, envPtr);
+ TclEmitInt4(-2, envPtr); /* -2 == "end" */
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileLindexCmd --
+ *
+ * Procedure called to compile the "lindex" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "lindex" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLindexCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *idxTokenPtr, *valTokenPtr;
+ int i, numWords = parsePtr->numWords;
+ DefineLineInformation; /* TIP #280 */
+
+ /*
+ * Quit if too few args.
+ */
+
+ if (numWords <= 1) {
+ return TCL_ERROR;
+ }
+
+ valTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ if (numWords != 3) {
+ goto emitComplexLindex;
+ }
+
+ idxTokenPtr = TokenAfter(valTokenPtr);
+ if (idxTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ Tcl_Obj *tmpObj;
+ int idx, result;
+
+ tmpObj = Tcl_NewStringObj(idxTokenPtr[1].start, idxTokenPtr[1].size);
+ result = TclGetIntFromObj(NULL, tmpObj, &idx);
+ TclDecrRefCount(tmpObj);
+
+ if (result == TCL_OK && idx >= 0) {
+ /*
+ * All checks have been completed, and we have exactly this
+ * construct:
+ * lindex <arbitraryValue> <posInt>
+ * This is best compiled as a push of the arbitrary value followed
+ * by an "immediate lindex" which is the most efficient variety.
+ */
+
+ CompileWord(envPtr, valTokenPtr, interp, 1);
+ TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
+ return TCL_OK;
+ }
+
+ /*
+ * If the conversion failed or the value was negative, we just keep on
+ * going with the more complex compilation.
+ */
+ }
+
+ /*
+ * Push the operands onto the stack.
+ */
+
+ emitComplexLindex:
+ for (i=1 ; i<numWords ; i++) {
+ CompileWord(envPtr, valTokenPtr, interp, i);
+ valTokenPtr = TokenAfter(valTokenPtr);
+ }
+
+ /*
+ * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI if there are
+ * multiple index args.
+ */
+
+ if (numWords == 3) {
+ TclEmitOpcode(INST_LIST_INDEX, envPtr);
} else {
- TclEmitInstInt4( INST_LIST_INDEX_MULTI, numWords-1, envPtr );
+ TclEmitInstInt4(INST_LIST_INDEX_MULTI, numWords-1, envPtr);
}
return TCL_OK;
@@ -1909,67 +2817,55 @@ TclCompileLindexCmd(interp, parsePtr, envPtr)
* Procedure called to compile the "list" command.
*
* Results:
- * The return value is a standard Tcl result, which is normally TCL_OK
- * unless there was an error while parsing string. If an error occurs
- * then the interpreter's result contains a standard error message. If
- * compilation fails because the command requires a second level of
- * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
- * command should be compiled "out of line" by emitting code to
- * invoke its command procedure (Tcl_ListObjCmd) at runtime.
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
*
* Side effects:
- * Instructions are added to envPtr to execute the "list" command
- * at runtime.
+ * Instructions are added to envPtr to execute the "list" command at
+ * runtime.
*
*----------------------------------------------------------------------
*/
int
-TclCompileListCmd(interp, parsePtr, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- Tcl_Parse *parsePtr; /* Points to a parse structure for the
- * command created by Tcl_ParseCommand. */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+TclCompileListCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
{
- DefineLineInformation;
+ DefineLineInformation; /* TIP #280 */
/*
* If we're not in a procedure, don't compile.
*/
+
if (envPtr->procPtr == NULL) {
- return TCL_OUT_LINE_COMPILE;
+ return TCL_ERROR;
}
if (parsePtr->numWords == 1) {
/*
- * Empty args case
+ * [list] without arguments just pushes an empty object.
*/
- TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
+ PushLiteral(envPtr, "", 0);
} else {
/*
* Push the all values onto the stack.
*/
+
Tcl_Token *valueTokenPtr;
- int i, code, numWords;
+ int i, numWords;
numWords = parsePtr->numWords;
- valueTokenPtr = parsePtr->tokenPtr
- + (parsePtr->tokenPtr->numComponents + 1);
+ valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
for (i = 1; i < numWords; i++) {
- if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- TclEmitPush(TclRegisterNewLiteral(envPtr,
- valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
- } else {
- SetLineInformation (i);
- code = TclCompileTokens(interp, valueTokenPtr+1,
- valueTokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- return code;
- }
- }
- valueTokenPtr = valueTokenPtr + (valueTokenPtr->numComponents + 1);
+ CompileWord(envPtr, valueTokenPtr, interp, i);
+ valueTokenPtr = TokenAfter(valueTokenPtr);
}
TclEmitInstInt4(INST_LIST, numWords - 1, envPtr);
}
@@ -1985,54 +2881,34 @@ TclCompileListCmd(interp, parsePtr, envPtr)
* Procedure called to compile the "llength" command.
*
* Results:
- * The return value is a standard Tcl result, which is TCL_OK if the
- * compilation was successful. If the command cannot be byte-compiled,
- * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the
- * interpreter's result contains an error message, and TCL_ERROR is
- * returned.
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
*
* Side effects:
- * Instructions are added to envPtr to execute the "llength" command
- * at runtime.
+ * Instructions are added to envPtr to execute the "llength" command at
+ * runtime.
*
*----------------------------------------------------------------------
*/
int
-TclCompileLlengthCmd(interp, parsePtr, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- Tcl_Parse *parsePtr; /* Points to a parse structure for the
- * command created by Tcl_ParseCommand. */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+TclCompileLlengthCmd(
+ 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 code;
-
- DefineLineInformation;
+ DefineLineInformation; /* TIP #280 */
if (parsePtr->numWords != 2) {
- Tcl_SetResult(interp, "wrong # args: should be \"llength list\"",
- TCL_STATIC);
return TCL_ERROR;
}
- varTokenPtr = parsePtr->tokenPtr
- + (parsePtr->tokenPtr->numComponents + 1);
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- /*
- * We could simply count the number of elements here and push
- * that value, but that is too rare a case to waste the code space.
- */
- TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
- varTokenPtr[1].size), envPtr);
- } else {
- SetLineInformation (1);
- code = TclCompileTokens(interp, varTokenPtr+1,
- varTokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- return code;
- }
- }
+ CompileWord(envPtr, varTokenPtr, interp, 1);
TclEmitOpcode(INST_LIST_LENGTH, envPtr);
return TCL_OK;
}
@@ -2045,197 +2921,175 @@ TclCompileLlengthCmd(interp, parsePtr, envPtr)
* Procedure called to compile the "lset" command.
*
* Results:
- * The return value is a standard Tcl result, which is TCL_OK if
- * the compilation was successful. If the "lset" command is too
- * complex for this function, then TCL_OUT_LINE_COMPILE is returned,
- * indicating that the command should be compiled "out of line"
- * (that is, not byte-compiled). If an error occurs, TCL_ERROR is
- * returned, and the interpreter result contains an error message.
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
*
* Side effects:
- * Instructions are added to envPtr to execute the "lset" command
- * at runtime.
+ * Instructions are added to envPtr to execute the "lset" command at
+ * runtime.
*
* The general template for execution of the "lset" command is:
- * (1) Instructions to push the variable name, unless the
- * variable is local to the stack frame.
- * (2) If the variable is an array element, instructions
- * to push the array element name.
- * (3) Instructions to push each of zero or more "index" arguments
- * to the stack, followed with the "newValue" element.
- * (4) Instructions to duplicate the variable name and/or array
- * element name onto the top of the stack, if either was
- * pushed at steps (1) and (2).
- * (5) The appropriate INST_LOAD_* instruction to place the
- * original value of the list variable at top of stack.
+ * (1) Instructions to push the variable name, unless the variable is
+ * local to the stack frame.
+ * (2) If the variable is an array element, instructions to push the
+ * array element name.
+ * (3) Instructions to push each of zero or more "index" arguments to the
+ * stack, followed with the "newValue" element.
+ * (4) Instructions to duplicate the variable name and/or array element
+ * name onto the top of the stack, if either was pushed at steps (1)
+ * and (2).
+ * (5) The appropriate INST_LOAD_* instruction to place the original
+ * value of the list variable at top of stack.
* (6) At this point, the stack contains:
- * varName? arrayElementName? index1 index2 ... newValue oldList
+ * varName? arrayElementName? index1 index2 ... newValue oldList
* The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST
- * according as whether there is exactly one index element (LIST)
- * or either zero or else two or more (FLAT). This instruction
- * removes everything from the stack except for the two names
- * and pushes the new value of the variable.
- * (7) Finally, INST_STORE_* stores the new value in the variable
- * and cleans up the stack.
+ * according as whether there is exactly one index element (LIST) or
+ * either zero or else two or more (FLAT). This instruction removes
+ * everything from the stack except for the two names and pushes the
+ * new value of the variable.
+ * (7) Finally, INST_STORE_* stores the new value in the variable and
+ * cleans up the stack.
*
*----------------------------------------------------------------------
*/
int
-TclCompileLsetCmd( interp, parsePtr, envPtr )
- Tcl_Interp* interp; /* Tcl interpreter for error reporting */
- Tcl_Parse* parsePtr; /* Points to a parse structure for
- * the command */
- CompileEnv* envPtr; /* Holds the resulting instructions */
+TclCompileLsetCmd(
+ Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the
+ * command. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds the resulting instructions. */
{
-
- int tempDepth; /* Depth used for emitting one part
- * of the code burst. */
- Tcl_Token* varTokenPtr; /* Pointer to the Tcl_Token representing
- * the parse of the variable name */
-
- int result; /* Status return from library calls */
-
- int localIndex; /* Index of var in local var table */
- int simpleVarName; /* Flag == 1 if var name is simple */
- int isScalar; /* Flag == 1 if scalar, 0 if array */
-
+ int tempDepth; /* Depth used for emitting one part of the
+ * code burst. */
+ Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
+ * parse of the variable name. */
+ int localIndex; /* Index of var in local var table. */
+ int simpleVarName; /* Flag == 1 if var name is simple. */
+ int isScalar; /* Flag == 1 if scalar, 0 if array. */
int i;
+ DefineLineInformation; /* TIP #280 */
- DefineLineInformation;
+ /*
+ * Check argument count.
+ */
- /* Check argument count */
+ if (parsePtr->numWords < 3) {
+ /*
+ * Fail at run time, not in compilation.
+ */
- if ( parsePtr->numWords < 3 ) {
- /* Fail at run time, not in compilation */
- return TCL_OUT_LINE_COMPILE;
+ 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.
+ * 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 = parsePtr->tokenPtr
- + (parsePtr->tokenPtr->numComponents + 1);
- result = TclPushVarNameWord( interp, varTokenPtr, envPtr,
- TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar, 1);
- if (result != TCL_OK) {
- return result;
- }
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
+ &localIndex, &simpleVarName, &isScalar, 1);
- /* Push the "index" args and the new element value. */
-
- for ( i = 2; i < parsePtr->numWords; ++i ) {
-
- /* Advance to next arg */
-
- varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
-
- /* Push an arg */
+ /*
+ * Push the "index" args and the new element value.
+ */
- if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- TclEmitPush(TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
- varTokenPtr[1].size), envPtr);
- } else {
- SetLineInformation (i);
- result = TclCompileTokens(interp, varTokenPtr+1,
- varTokenPtr->numComponents, envPtr);
- if ( result != TCL_OK ) {
- return result;
- }
- }
+ for (i=2 ; i<parsePtr->numWords ; ++i) {
+ varTokenPtr = TokenAfter(varTokenPtr);
+ CompileWord(envPtr, varTokenPtr, interp, i);
}
/*
- * Duplicate the variable name if it's been pushed.
+ * Duplicate the variable name if it's been pushed.
*/
- if ( !simpleVarName || localIndex < 0 ) {
- if ( !simpleVarName || isScalar ) {
+ if (!simpleVarName || localIndex < 0) {
+ if (!simpleVarName || isScalar) {
tempDepth = parsePtr->numWords - 2;
} else {
tempDepth = parsePtr->numWords - 1;
}
- TclEmitInstInt4( INST_OVER, tempDepth, envPtr );
+ TclEmitInstInt4(INST_OVER, tempDepth, envPtr);
}
/*
- * Duplicate an array index if one's been pushed
+ * Duplicate an array index if one's been pushed.
*/
- if ( simpleVarName && !isScalar ) {
- if ( localIndex < 0 ) {
+ if (simpleVarName && !isScalar) {
+ if (localIndex < 0) {
tempDepth = parsePtr->numWords - 1;
} else {
tempDepth = parsePtr->numWords - 2;
}
- TclEmitInstInt4( INST_OVER, tempDepth, envPtr );
+ TclEmitInstInt4(INST_OVER, tempDepth, envPtr);
}
/*
* Emit code to load the variable's value.
*/
- if ( !simpleVarName ) {
- TclEmitOpcode( INST_LOAD_STK, envPtr );
- } else if ( isScalar ) {
- if ( localIndex < 0 ) {
- TclEmitOpcode( INST_LOAD_SCALAR_STK, envPtr );
- } else if ( localIndex < 0x100 ) {
- TclEmitInstInt1( INST_LOAD_SCALAR1, localIndex, envPtr );
+ if (!simpleVarName) {
+ TclEmitOpcode(INST_LOAD_STK, envPtr);
+ } else if (isScalar) {
+ if (localIndex < 0) {
+ TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
+ } else if (localIndex < 0x100) {
+ TclEmitInstInt1(INST_LOAD_SCALAR1, localIndex, envPtr);
} else {
- TclEmitInstInt4( INST_LOAD_SCALAR4, localIndex, envPtr );
+ TclEmitInstInt4(INST_LOAD_SCALAR4, localIndex, envPtr);
}
} else {
- if ( localIndex < 0 ) {
- TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr );
- } else if ( localIndex < 0x100 ) {
- TclEmitInstInt1( INST_LOAD_ARRAY1, localIndex, envPtr );
+ if (localIndex < 0) {
+ TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
+ } else if (localIndex < 0x100) {
+ TclEmitInstInt1(INST_LOAD_ARRAY1, localIndex, envPtr);
} else {
- TclEmitInstInt4( INST_LOAD_ARRAY4, localIndex, envPtr );
+ TclEmitInstInt4(INST_LOAD_ARRAY4, localIndex, envPtr);
}
}
/*
- * Emit the correct variety of 'lset' instruction
+ * Emit the correct variety of 'lset' instruction.
*/
- if ( parsePtr->numWords == 4 ) {
- TclEmitOpcode( INST_LSET_LIST, envPtr );
+ if (parsePtr->numWords == 4) {
+ TclEmitOpcode(INST_LSET_LIST, envPtr);
} else {
- TclEmitInstInt4( INST_LSET_FLAT, (parsePtr->numWords - 1), envPtr );
+ TclEmitInstInt4(INST_LSET_FLAT, parsePtr->numWords-1, envPtr);
}
/*
- * Emit code to put the value back in the variable
+ * Emit code to put the value back in the variable.
*/
- if ( !simpleVarName ) {
- TclEmitOpcode( INST_STORE_STK, envPtr );
- } else if ( isScalar ) {
- if ( localIndex < 0 ) {
- TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr );
- } else if ( localIndex < 0x100 ) {
- TclEmitInstInt1( INST_STORE_SCALAR1, localIndex, envPtr );
+ if (!simpleVarName) {
+ TclEmitOpcode(INST_STORE_STK, envPtr);
+ } else if (isScalar) {
+ if (localIndex < 0) {
+ TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr);
+ } else if (localIndex < 0x100) {
+ TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
} else {
- TclEmitInstInt4( INST_STORE_SCALAR4, localIndex, envPtr );
+ TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
}
} else {
- if ( localIndex < 0 ) {
- TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr );
- } else if ( localIndex < 0x100 ) {
- TclEmitInstInt1( INST_STORE_ARRAY1, localIndex, envPtr );
+ if (localIndex < 0) {
+ TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr);
+ } else if (localIndex < 0x100) {
+ TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr);
} else {
- TclEmitInstInt4( INST_STORE_ARRAY4, localIndex, envPtr );
+ TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr);
}
}
-
- return TCL_OK;
+ return TCL_OK;
}
/*
@@ -2246,193 +3100,155 @@ TclCompileLsetCmd( interp, parsePtr, envPtr )
* Procedure called to compile the "regexp" command.
*
* Results:
- * The return value is a standard Tcl result, which is TCL_OK if
- * the compilation was successful. If the "regexp" command is too
- * complex for this function, then TCL_OUT_LINE_COMPILE is returned,
- * indicating that the command should be compiled "out of line"
- * (that is, not byte-compiled). If an error occurs, TCL_ERROR is
- * returned, and the interpreter result contains an error message.
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
*
* Side effects:
- * Instructions are added to envPtr to execute the "regexp" command
- * at runtime.
+ * Instructions are added to envPtr to execute the "regexp" command at
+ * runtime.
*
*----------------------------------------------------------------------
*/
int
-TclCompileRegexpCmd(interp, parsePtr, envPtr)
- Tcl_Interp* interp; /* Tcl interpreter for error reporting */
- Tcl_Parse* parsePtr; /* Points to a parse structure for
- * the command */
- CompileEnv* envPtr; /* Holds the resulting instructions */
-{
- Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing
- * the parse of the RE or string */
- int i, len, code, nocase, anchorLeft, anchorRight, start;
+TclCompileRegexpCmd(
+ Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the
+ * command. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds the resulting instructions. */
+{
+ Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
+ * parse of the RE or string. */
+ int i, len, nocase, exact, sawLast, simple;
char *str;
-
- DefineLineInformation;
+ DefineLineInformation; /* TIP #280 */
/*
- * We are only interested in compiling simple regexp cases.
- * Currently supported compile cases are:
+ * We are only interested in compiling simple regexp cases. Currently
+ * supported compile cases are:
* regexp ?-nocase? ?--? staticString $var
* regexp ?-nocase? ?--? {^staticString$} $var
*/
+
if (parsePtr->numWords < 3) {
- return TCL_OUT_LINE_COMPILE;
+ return TCL_ERROR;
}
+ simple = 0;
nocase = 0;
+ sawLast = 0;
varTokenPtr = parsePtr->tokenPtr;
/*
- * We only look for -nocase and -- as options. Everything else
- * gets pushed to runtime execution. This is different than regexp's
- * runtime option handling, but satisfies our stricter needs.
+ * We only look for -nocase and -- as options. Everything else gets pushed
+ * to runtime execution. This is different than regexp's runtime option
+ * handling, but satisfies our stricter needs.
*/
+
for (i = 1; i < parsePtr->numWords - 2; i++) {
- varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
+ varTokenPtr = TokenAfter(varTokenPtr);
if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- /* Not a simple string - punt to runtime. */
- return TCL_OUT_LINE_COMPILE;
+ /*
+ * Not a simple string, so punt to runtime.
+ */
+
+ return TCL_ERROR;
}
str = (char *) varTokenPtr[1].start;
len = varTokenPtr[1].size;
if ((len == 2) && (str[0] == '-') && (str[1] == '-')) {
+ sawLast++;
i++;
break;
- } else if ((len > 1)
- && (strncmp(str, "-nocase", (unsigned) len) == 0)) {
+ } else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) {
nocase = 1;
} else {
- /* Not an option we recognize. */
- return TCL_OUT_LINE_COMPILE;
+ /*
+ * Not an option we recognize.
+ */
+
+ return TCL_ERROR;
}
}
if ((parsePtr->numWords - i) != 2) {
- /* We don't support capturing to variables */
- return TCL_OUT_LINE_COMPILE;
+ /*
+ * We don't support capturing to variables.
+ */
+
+ return TCL_ERROR;
}
/*
- * Get the regexp string. If it is not a simple string, punt to runtime.
- * If it has a '-', it could be an incorrectly formed regexp command.
+ * Get the regexp string. If it is not a simple string or can't be
+ * converted to a glob pattern, push the word for the INST_REGEXP.
+ * Keep changes here in sync with TclCompileSwitchCmd Switch_Regexp.
*/
- varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
- str = (char *) varTokenPtr[1].start;
- len = varTokenPtr[1].size;
- if ((varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || (*str == '-')) {
- return TCL_OUT_LINE_COMPILE;
- }
- if (len == 0) {
+ varTokenPtr = TokenAfter(varTokenPtr);
+
+ if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ Tcl_DString ds;
+
+ str = (char *) varTokenPtr[1].start;
+ len = varTokenPtr[1].size;
/*
- * The semantics of regexp are always match on re == "".
+ * If it has a '-', it could be an incorrectly formed regexp command.
*/
- TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr);
- return TCL_OK;
- }
-
- /*
- * Make a copy of the string that is null-terminated for checks which
- * require such.
- */
- str = (char *) ckalloc((unsigned) len + 1);
- strncpy(str, varTokenPtr[1].start, (size_t) len);
- str[len] = '\0';
- start = 0;
- /*
- * Check for anchored REs (ie ^foo$), so we can use string equal if
- * possible. Do not alter the start of str so we can free it correctly.
- */
- if (str[0] == '^') {
- start++;
- anchorLeft = 1;
- } else {
- anchorLeft = 0;
- }
- if ((str[len-1] == '$') && ((len == 1) || (str[len-2] != '\\'))) {
- anchorRight = 1;
- str[--len] = '\0';
- } else {
- anchorRight = 0;
- }
+ if ((*str == '-') && !sawLast) {
+ return TCL_ERROR;
+ }
- /*
- * On the first (pattern) arg, check to see if any RE special characters
- * are in the word. If not, this is the same as 'string equal'.
- */
- if ((len > (1+start)) && (str[start] == '.') && (str[start+1] == '*')) {
- start += 2;
- anchorLeft = 0;
- }
- if ((len > (2+start)) && (str[len-3] != '\\')
- && (str[len-2] == '.') && (str[len-1] == '*')) {
- len -= 2;
- str[len] = '\0';
- anchorRight = 0;
- }
+ if (len == 0) {
+ /*
+ * The semantics of regexp are always match on re == "".
+ */
- /*
- * Don't do anything with REs with other special chars. Also check if
- * this is a bad RE (do this at the end because it can be expensive).
- * If so, let it complain at runtime.
- */
- if ((strpbrk(str + start, "*+?{}()[].\\|^$") != NULL)
- || (Tcl_RegExpCompile(NULL, str) == NULL)) {
- ckfree((char *) str);
- return TCL_OUT_LINE_COMPILE;
- }
+ PushLiteral(envPtr, "1", 1);
+ return TCL_OK;
+ }
- if (anchorLeft && anchorRight) {
- TclEmitPush(TclRegisterNewLiteral(envPtr, str+start, len-start),
- envPtr);
- } else {
/*
- * This needs to find the substring anywhere in the string, so
- * use string match and *foo*, with appropriate anchoring.
+ * Attempt to convert pattern to glob. If successful, push the
+ * converted pattern as a literal.
*/
- char *newStr = ckalloc((unsigned) len + 3);
- len -= start;
- if (anchorLeft) {
- strncpy(newStr, str + start, (size_t) len);
- } else {
- newStr[0] = '*';
- strncpy(newStr + 1, str + start, (size_t) len++);
- }
- if (!anchorRight) {
- newStr[len++] = '*';
+
+ if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact)
+ == TCL_OK) {
+ simple = 1;
+ PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
}
- newStr[len] = '\0';
- TclEmitPush(TclRegisterNewLiteral(envPtr, newStr, len), envPtr);
- ckfree((char *) newStr);
}
- ckfree((char *) str);
+
+ if (!simple) {
+ CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2);
+ }
/*
- * Push the string arg
+ * Push the string arg.
*/
- varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
- if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- TclEmitPush(TclRegisterNewLiteral(envPtr,
- varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
- } else {
- SetLineInformation (parsePtr->numWords-1);
- code = TclCompileTokens(interp, varTokenPtr+1,
- varTokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- return code;
- }
- }
- if (anchorLeft && anchorRight && !nocase) {
- TclEmitOpcode(INST_STR_EQ, envPtr);
+ varTokenPtr = TokenAfter(varTokenPtr);
+ CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1);
+
+ if (simple) {
+ if (exact && !nocase) {
+ TclEmitOpcode(INST_STR_EQ, envPtr);
+ } else {
+ TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
+ }
} else {
- TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
+ /*
+ * Pass correct RE compile flags. We use only Int1 (8-bit), but
+ * that handles all the flags we want to pass.
+ * Don't use TCL_REG_NOSUB as we may have backrefs.
+ */
+ int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0);
+ TclEmitInstInt1(INST_REGEXP, cflags, envPtr);
}
return TCL_OK;
@@ -2446,117 +3262,191 @@ TclCompileRegexpCmd(interp, parsePtr, envPtr)
* Procedure called to compile the "return" command.
*
* Results:
- * The return value is a standard Tcl result, which is TCL_OK if the
- * compilation was successful. If the particular return command is
- * too complex for this function (ie, return with any flags like "-code"
- * or "-errorinfo"), TCL_OUT_LINE_COMPILE is returned, indicating that
- * the command should be compiled "out of line" (eg, not byte compiled).
- * If an error occurs then the interpreter's result contains a standard
- * error message.
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
*
* Side effects:
- * Instructions are added to envPtr to execute the "return" command
- * at runtime.
+ * Instructions are added to envPtr to execute the "return" command at
+ * runtime.
*
*----------------------------------------------------------------------
*/
int
-TclCompileReturnCmd(interp, parsePtr, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- Tcl_Parse *parsePtr; /* Points to a parse structure for the
- * command created by Tcl_ParseCommand. */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+TclCompileReturnCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
{
- Tcl_Token *varTokenPtr;
- int code;
- int index = envPtr->exceptArrayNext - 1;
-
- DefineLineInformation;
+ /*
+ * General syntax: [return ?-option value ...? ?result?]
+ * An even number of words means an explicit result argument is present.
+ */
+ int level, code, objc, size, status = TCL_OK;
+ int numWords = parsePtr->numWords;
+ int explicitResult = (0 == (numWords % 2));
+ int numOptionWords = numWords - 1 - explicitResult;
+ Tcl_Obj *returnOpts, **objv;
+ Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ DefineLineInformation; /* TIP #280 */
/*
- * If we're not in a procedure, don't compile.
+ * Check for special case which can always be compiled:
+ * return -options <opts> <msg>
+ * Unlike the normal [return] compilation, this version does everything at
+ * runtime so it can handle arbitrary words and not just literals. Note
+ * that if INST_RETURN_STK wasn't already needed for something else
+ * ('finally' clause processing) this piece of code would not be present.
*/
- if (envPtr->procPtr == NULL) {
- return TCL_OUT_LINE_COMPILE;
+ if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD)
+ && (wordTokenPtr[1].size == 8)
+ && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) {
+ Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr);
+ Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr);
+
+ CompileWord(envPtr, optsTokenPtr, interp, 2);
+ CompileWord(envPtr, msgTokenPtr, interp, 3);
+ TclEmitOpcode(INST_RETURN_STK, envPtr);
+ return TCL_OK;
}
/*
- * Look back through the ExceptionRanges of the current CompileEnv,
- * from exceptArrayPtr[(exceptArrayNext - 1)] down to
- * exceptArrayPtr[0] to see if any of them is an enclosing [catch].
- * If there's an enclosing [catch], don't compile.
+ * Allocate some working space.
+ */
+
+ objv = (Tcl_Obj **) TclStackAlloc(interp,
+ numOptionWords * sizeof(Tcl_Obj *));
+
+ /*
+ * Scan through the return options. If any are unknown at compile time,
+ * there is no value in bytecompiling. Save the option values known in an
+ * objv array for merging into a return options dictionary.
*/
- while (index >= 0) {
- ExceptionRange range = envPtr->exceptArrayPtr[index];
- if ((range.type == CATCH_EXCEPTION_RANGE)
- && (range.catchOffset == -1)) {
- return TCL_OUT_LINE_COMPILE;
+ for (objc = 0; objc < numOptionWords; objc++) {
+ objv[objc] = Tcl_NewObj();
+ Tcl_IncrRefCount(objv[objc]);
+ if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
+ objc++;
+ status = TCL_ERROR;
+ goto cleanup;
}
- index--;
+ wordTokenPtr = TokenAfter(wordTokenPtr);
+ }
+ status = TclMergeReturnOptions(interp, objc, objv,
+ &returnOpts, &code, &level);
+ cleanup:
+ while (--objc >= 0) {
+ TclDecrRefCount(objv[objc]);
}
+ TclStackFree(interp, objv);
+ if (TCL_ERROR == status) {
+ /*
+ * Something was bogus in the return options. Clear the error message,
+ * and report back to the compiler that this must be interpreted at
+ * runtime.
+ */
- switch (parsePtr->numWords) {
- case 1: {
- /*
- * Simple case: [return]
- * Just push the literal string "".
- */
- TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
- break;
- }
- case 2: {
- /*
- * More complex cases:
- * [return "foo"]
- * [return $value]
- * [return [otherCmd]]
- */
- varTokenPtr = parsePtr->tokenPtr
- + (parsePtr->tokenPtr->numComponents + 1);
- if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- /*
- * [return "foo"] case: the parse token is a simple word,
- * so just push it.
- */
- TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
- varTokenPtr[1].size), envPtr);
- } else {
- /*
- * Parse token is more complex, so compile it; this handles the
- * variable reference and nested command cases. If the
- * parse token can be byte-compiled, then this instance of
- * "return" will be byte-compiled; otherwise it will be
- * out line compiled.
- */
- SetLineInformation (1);
- code = TclCompileTokens(interp, varTokenPtr+1,
- varTokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- return code;
- }
+ Tcl_ResetResult(interp);
+ return TCL_ERROR;
+ }
+
+ /*
+ * All options are known at compile time, so we're going to bytecompile.
+ * Emit instructions to push the result on the stack.
+ */
+
+ if (explicitResult) {
+ CompileWord(envPtr, wordTokenPtr, interp, numWords-1);
+ } else {
+ /*
+ * No explict result argument, so default result is empty string.
+ */
+
+ PushLiteral(envPtr, "", 0);
+ }
+
+ /*
+ * Check for optimization: When [return] is in a proc, and there's no
+ * enclosing [catch], and there are no return options, then the INST_DONE
+ * instruction is equivalent, and may be more efficient.
+ */
+
+ if (numOptionWords == 0 && envPtr->procPtr != NULL) {
+ /*
+ * We have default return options and we're in a proc ...
+ */
+
+ int index = envPtr->exceptArrayNext - 1;
+ int enclosingCatch = 0;
+
+ while (index >= 0) {
+ ExceptionRange range = envPtr->exceptArrayPtr[index];
+ if ((range.type == CATCH_EXCEPTION_RANGE)
+ && (range.catchOffset == -1)) {
+ enclosingCatch = 1;
+ break;
}
- break;
+ index--;
}
- default: {
+ if (!enclosingCatch) {
/*
- * Most complex return cases: everything else, including
- * [return -code error], etc.
+ * ... and there is no enclosing catch. Issue the maximally
+ * efficient exit instruction.
*/
- return TCL_OUT_LINE_COMPILE;
+
+ Tcl_DecrRefCount(returnOpts);
+ TclEmitOpcode(INST_DONE, envPtr);
+ return TCL_OK;
}
}
+ /* Optimize [return -level 0 $x]. */
+ Tcl_DictObjSize(NULL, returnOpts, &size);
+ if (size == 0 && level == 0 && code == TCL_OK) {
+ Tcl_DecrRefCount(returnOpts);
+ return TCL_OK;
+ }
+
/*
- * The INST_DONE opcode actually causes the branching out of the
- * subroutine, and takes the top stack item as the return result
- * (which is why we pushed the value above).
+ * Could not use the optimization, so we push the return options dict, and
+ * emit the INST_RETURN_IMM instruction with code and level as operands.
*/
- TclEmitOpcode(INST_DONE, envPtr);
+
+ CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts);
return TCL_OK;
}
+
+static void
+CompileReturnInternal(
+ CompileEnv *envPtr,
+ unsigned char op,
+ int code,
+ int level,
+ Tcl_Obj *returnOpts)
+{
+ TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr);
+ TclEmitInstInt4(op, code, envPtr);
+ TclEmitInt4(level, envPtr);
+}
+
+void
+TclCompileSyntaxError(
+ Tcl_Interp *interp,
+ CompileEnv *envPtr)
+{
+ Tcl_Obj *msg = Tcl_GetObjResult(interp);
+ int numBytes;
+ const char *bytes = TclGetStringFromObj(msg, &numBytes);
+
+ TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr);
+ CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0,
+ Tcl_GetReturnOptions(interp, TCL_ERROR));
+}
/*
*----------------------------------------------------------------------
@@ -2566,77 +3456,54 @@ TclCompileReturnCmd(interp, parsePtr, envPtr)
* Procedure called to compile the "set" command.
*
* Results:
- * The return value is a standard Tcl result, which is normally TCL_OK
- * unless there was an error while parsing string. If an error occurs
- * then the interpreter's result contains a standard error message. If
- * compilation fails because the set command requires a second level of
- * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
- * set command should be compiled "out of line" by emitting code to
- * invoke its command procedure (Tcl_SetCmd) at runtime.
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
*
* Side effects:
- * Instructions are added to envPtr to execute the "set" command
- * at runtime.
+ * Instructions are added to envPtr to execute the "set" command at
+ * runtime.
*
*----------------------------------------------------------------------
*/
int
-TclCompileSetCmd(interp, parsePtr, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- Tcl_Parse *parsePtr; /* Points to a parse structure for the
- * command created by Tcl_ParseCommand. */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+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;
- int code = TCL_OK;
-
- DefineLineInformation;
+ DefineLineInformation; /* TIP #280 */
numWords = parsePtr->numWords;
if ((numWords != 2) && (numWords != 3)) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"set varName ?newValue?\"", -1);
- return TCL_ERROR;
+ 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.
+ * 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 = parsePtr->tokenPtr
- + (parsePtr->tokenPtr->numComponents + 1);
-
- code = TclPushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
- &localIndex, &simpleVarName, &isScalar, 1);
- if (code != TCL_OK) {
- goto done;
- }
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
+ &localIndex, &simpleVarName, &isScalar, 1);
/*
* If we are doing an assignment, push the new value.
*/
if (isAssignment) {
- valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
- if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start,
- valueTokenPtr[1].size), envPtr);
- } else {
- SetLineInformation (2);
- code = TclCompileTokens(interp, valueTokenPtr+1,
- valueTokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- goto done;
- }
- }
+ valueTokenPtr = TokenAfter(varTokenPtr);
+ CompileWord(envPtr, valueTokenPtr, interp, 2);
}
/*
@@ -2645,351 +3512,1158 @@ TclCompileSetCmd(interp, parsePtr, envPtr)
if (simpleVarName) {
if (isScalar) {
- if (localIndex >= 0) {
- 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_SCALAR_STK : INST_LOAD_SCALAR_STK), envPtr);
+ 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) {
- 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 {
+ if (localIndex < 0) {
TclEmitOpcode((isAssignment?
- INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr);
+ 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);
}
-
- done:
- return code;
+
+ return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * TclCompileStringCmd --
+ * TclCompileStringCmpCmd --
*
- * Procedure called to compile the "string" command.
+ * Procedure called to compile the simplest and most common form of the
+ * "string compare" command.
*
* Results:
- * The return value is a standard Tcl result, which is TCL_OK if the
- * compilation was successful. If the command cannot be byte-compiled,
- * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the
- * interpreter's result contains an error message, and TCL_ERROR is
- * returned.
+ * 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" command
+ * 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
-TclCompileStringCmd(interp, parsePtr, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- Tcl_Parse *parsePtr; /* Points to a parse structure for the
- * command created by Tcl_ParseCommand. */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- Tcl_Token *opTokenPtr, *varTokenPtr;
- Tcl_Obj *opObj;
- int index;
- int code;
-
- static CONST char *options[] = {
- "bytelength", "compare", "equal", "first",
- "index", "is", "last", "length",
- "map", "match", "range", "repeat",
- "replace", "tolower", "toupper", "totitle",
- "trim", "trimleft", "trimright",
- "wordend", "wordstart", (char *) NULL
- };
- enum options {
- STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST,
- STR_INDEX, STR_IS, STR_LAST, STR_LENGTH,
- STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT,
- STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE,
- STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT,
- STR_WORDEND, STR_WORDSTART
- };
-
- DefineLineInformation;
+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;
- if (parsePtr->numWords < 2) {
- /* Fail at run time, not in compilation */
- return TCL_OUT_LINE_COMPILE;
+ /*
+ * We don't support any flags; the bytecode isn't that sophisticated.
+ */
+
+ if (parsePtr->numWords != 3) {
+ return TCL_ERROR;
}
- opTokenPtr = parsePtr->tokenPtr
- + (parsePtr->tokenPtr->numComponents + 1);
- opObj = Tcl_NewStringObj(opTokenPtr->start, opTokenPtr->size);
- if (Tcl_GetIndexFromObj(interp, opObj, options, "option", 0,
- &index) != TCL_OK) {
- Tcl_DecrRefCount(opObj);
- Tcl_ResetResult(interp);
- return TCL_OUT_LINE_COMPILE;
- }
- Tcl_DecrRefCount(opObj);
-
- varTokenPtr = opTokenPtr + (opTokenPtr->numComponents + 1);
-
- switch ((enum options) index) {
- case STR_BYTELENGTH:
- case STR_FIRST:
- case STR_IS:
- case STR_LAST:
- case STR_MAP:
- case STR_RANGE:
- case STR_REPEAT:
- case STR_REPLACE:
- case STR_TOLOWER:
- case STR_TOUPPER:
- case STR_TOTITLE:
- case STR_TRIM:
- case STR_TRIMLEFT:
- case STR_TRIMRIGHT:
- case STR_WORDEND:
- case STR_WORDSTART:
+ /*
+ * 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(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr;
+
+ if (parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Push the two operands onto the stack and then the index operation.
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ TclEmitOpcode(INST_STR_INDEX, envPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileStringMatchCmd --
+ *
+ * Procedure called to compile the simplest and most common form of the
+ * "string match" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "string match" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileStringMatchCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr;
+ int i, length, exactMatch = 0, nocase = 0;
+ const char *str;
+
+ if (parsePtr->numWords < 3 || parsePtr->numWords > 4) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ /*
+ * Check if we have a -nocase flag.
+ */
+
+ if (parsePtr->numWords == 4) {
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ str = tokenPtr[1].start;
+ length = tokenPtr[1].size;
+ if ((length <= 1) || strncmp(str, "-nocase", (size_t) length)) {
+ /*
+ * Fail at run time, not in compilation.
+ */
+
+ return TCL_ERROR;
+ }
+ nocase = 1;
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+
+ /*
+ * Push the strings to match against each other.
+ */
+
+ for (i = 0; i < 2; i++) {
+ if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ str = tokenPtr[1].start;
+ length = tokenPtr[1].size;
+ if (!nocase && (i == 0)) {
+ /*
+ * Trivial matches can be done by 'string equal'. If -nocase
+ * was specified, we can't do this because INST_STR_EQ has no
+ * support for nocase.
+ */
+
+ Tcl_Obj *copy = Tcl_NewStringObj(str, length);
+
+ Tcl_IncrRefCount(copy);
+ exactMatch = TclMatchIsTrivial(TclGetString(copy));
+ TclDecrRefCount(copy);
+ }
+ PushLiteral(envPtr, str, length);
+ } else {
+ SetLineInformation (i+1+nocase);
+ CompileTokens(envPtr, tokenPtr, interp);
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+
+ /*
+ * Push the matcher.
+ */
+
+ if (exactMatch) {
+ TclEmitOpcode(INST_STR_EQ, envPtr);
+ } else {
+ TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileStringLenCmd --
+ *
+ * Procedure called to compile the simplest and most common form of the
+ * "string length" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "string length"
+ * command at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileStringLenCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr;
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ /*
+ * Here someone is asking for the length of a static string. Just push
+ * the actual character (not byte) length.
+ */
+
+ char buf[TCL_INTEGER_SPACE];
+ int len = Tcl_NumUtfChars(tokenPtr[1].start, tokenPtr[1].size);
+
+ len = sprintf(buf, "%d", len);
+ PushLiteral(envPtr, buf, len);
+ } else {
+ SetLineInformation (1);
+ CompileTokens(envPtr, tokenPtr, interp);
+ TclEmitOpcode(INST_STR_LEN, envPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileSwitchCmd --
+ *
+ * Procedure called to compile the "switch" command.
+ *
+ * Results:
+ * Returns TCL_OK for successful compile, or TCL_ERROR to defer
+ * evaluation to runtime (either when it is too complex to get the
+ * semantics right, or when we know for sure that it is an error but need
+ * the error to happen at the right time).
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "switch" command at
+ * runtime.
+ *
+ * FIXME:
+ * Stack depths are probably not calculated correctly.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileSwitchCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr; /* Pointer to tokens in command. */
+ int numWords; /* Number of words in command. */
+
+ Tcl_Token *valueTokenPtr; /* Token for the value to switch on. */
+ enum {Switch_Exact, Switch_Glob, Switch_Regexp} mode;
+ /* What kind of switch are we doing? */
+
+ Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */
+ Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */
+ int *bodyLines; /* Array of line numbers for body list
+ * items. */
+ int** bodyNext;
+ int foundDefault; /* Flag to indicate whether a "default" clause
+ * is present. */
+
+ JumpFixup *fixupArray; /* Array of forward-jump fixup records. */
+ int *fixupTargetArray; /* Array of places for fixups to point at. */
+ int fixupCount; /* Number of places to fix up. */
+ int contFixIndex; /* Where the first of the jumps due to a group
+ * of continuation bodies starts, or -1 if
+ * there aren't any. */
+ int contFixCount; /* Number of continuation bodies pointing to
+ * the current (or next) real body. */
+
+ int savedStackDepth = envPtr->currStackDepth;
+ int noCase; /* Has the -nocase flag been given? */
+ int foundMode = 0; /* Have we seen a mode flag yet? */
+ int i, valueIndex;
+ DefineLineInformation; /* TIP #280 */
+ int* clNext = envPtr->clNext;
+
+ /*
+ * Only handle the following versions:
+ * switch ?--? word {pattern body ...}
+ * switch -exact ?--? word {pattern body ...}
+ * switch -glob ?--? word {pattern body ...}
+ * switch -regexp ?--? word {pattern body ...}
+ * switch -- word simpleWordPattern simpleWordBody ...
+ * switch -exact -- word simpleWordPattern simpleWordBody ...
+ * switch -glob -- word simpleWordPattern simpleWordBody ...
+ * switch -regexp -- word simpleWordPattern simpleWordBody ...
+ * When the mode is -glob, can also handle a -nocase flag.
+ *
+ * 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;
+
+ /*
+ * We only process literal options, and we assume that -e, -g and -n
+ * are unique prefixes of -exact, -glob and -nocase respectively (true
+ * at time of writing). Note that -exact and -glob may only be given
+ * at most once or we bail out (error case).
+ */
+
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || size < 2) {
+ return TCL_ERROR;
+ }
+
+ if ((size <= 6) && !memcmp(chrs, "-exact", size)) {
+ if (foundMode) {
+ return TCL_ERROR;
+ }
+ mode = Switch_Exact;
+ foundMode = 1;
+ valueIndex++;
+ continue;
+ } else if ((size <= 5) && !memcmp(chrs, "-glob", size)) {
+ if (foundMode) {
+ return TCL_ERROR;
+ }
+ mode = Switch_Glob;
+ foundMode = 1;
+ valueIndex++;
+ continue;
+ } else if ((size <= 7) && !memcmp(chrs, "-regexp", size)) {
+ if (foundMode) {
+ return TCL_ERROR;
+ }
+ mode = Switch_Regexp;
+ foundMode = 1;
+ valueIndex++;
+ continue;
+ } else if ((size <= 7) && !memcmp(chrs, "-nocase", size)) {
+ noCase = 1;
+ valueIndex++;
+ continue;
+ } else if ((size == 2) && !memcmp(chrs, "--", 2)) {
+ valueIndex++;
+ break;
+ }
+
+ /*
+ * The switch command has many flags we cannot compile at all (e.g.
+ * all the RE-related ones) which we must have encountered. Either
+ * that or we have run off the end. The action here is the same: punt
+ * to interpreted version.
+ */
+
+ return TCL_ERROR;
+ }
+ if (numWords < 3) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ numWords--;
+ if (noCase && (mode == Switch_Exact)) {
+ /*
+ * Can't compile this case; no opcode for case-insensitive equality!
+ */
+
+ return TCL_ERROR;
+ }
+
+ /*
+ * 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.
+ */
+
+ if (numWords == 1) {
+ CONST char *bytes;
+ int maxLen, numBytes;
+ int bline; /* TIP #280: line of the pattern/action list,
+ * and start of list for when tracking the
+ * location. This list comes immediately after
+ * the value we switch on. */
+
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ bytes = tokenPtr[1].start;
+ numBytes = tokenPtr[1].size;
+
+ /* Allocate enough space to work in. */
+ maxLen = TclMaxListLength(bytes, numBytes, NULL);
+ if (maxLen < 2) {
+ return TCL_ERROR;
+ }
+ bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * maxLen);
+ bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * maxLen);
+ bodyLines = (int *) ckalloc(sizeof(int) * maxLen);
+ bodyNext = (int **) ckalloc(sizeof(int*) * maxLen);
+
+ bline = mapPtr->loc[eclIndex].line[valueIndex+1];
+ numWords = 0;
+
+ while (numBytes > 0) {
+ CONST char *prevBytes = bytes;
+ int literal;
+
+ if (TCL_OK != TclFindElement(NULL, bytes, numBytes,
+ &(bodyTokenArray[numWords].start), &bytes,
+ &(bodyTokenArray[numWords].size), &literal) || !literal) {
+ abort:
+ ckfree((char *) bodyToken);
+ ckfree((char *) bodyTokenArray);
+ ckfree((char *) bodyLines);
+ ckfree((char *) bodyNext);
+ return TCL_ERROR;
+ }
+
+ bodyTokenArray[numWords].type = TCL_TOKEN_TEXT;
+ bodyTokenArray[numWords].numComponents = 0;
+ bodyToken[numWords] = bodyTokenArray + numWords;
+
/*
- * All other cases: compile out of line.
+ * 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).
*/
- return TCL_OUT_LINE_COMPILE;
- case STR_COMPARE:
- case STR_EQUAL: {
- int i;
+ TclAdvanceLines(&bline, prevBytes, bodyTokenArray[numWords].start);
+ TclAdvanceContinuations (&bline, &clNext,
+ bodyTokenArray[numWords].start - envPtr->source);
+ bodyLines[numWords] = bline;
+ bodyNext[numWords] = clNext;
+ TclAdvanceLines(&bline, bodyTokenArray[numWords].start, bytes);
+ TclAdvanceContinuations (&bline, &clNext, bytes - envPtr->source);
+
+ numBytes -= (bytes - prevBytes);
+ numWords++;
+ }
+ if (numWords % 2) {
+ goto abort;
+ }
+ } else if (numWords % 2 || numWords == 0) {
+ /*
+ * Odd number of words (>1) available, or no words at all available.
+ * Both are error cases, so punt and let the interpreted-version
+ * generate the error message. Note that the second case probably
+ * should get caught earlier, but it's easy to check here again anyway
+ * because it'd cause a nasty crash otherwise.
+ */
+
+ return TCL_ERROR;
+ } else {
+ /*
+ * Multi-word definition of patterns & actions.
+ */
+
+ bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords);
+ bodyLines = (int *) ckalloc(sizeof(int) * numWords);
+ bodyNext = (int **) ckalloc(sizeof(int*) * numWords);
+ bodyTokenArray = NULL;
+ for (i=0 ; i<numWords ; i++) {
/*
- * If there are any flags to the command, we can't byte compile it
- * because the INST_STR_EQ bytecode doesn't support flags.
+ * 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 (parsePtr->numWords != 4) {
- return TCL_OUT_LINE_COMPILE;
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ ckfree((char *) bodyToken);
+ ckfree((char *) bodyLines);
+ ckfree((char *) bodyNext);
+ return TCL_ERROR;
}
+ bodyToken[i] = tokenPtr+1;
/*
- * Push the two operands onto the stack.
+ * TIP #280: Copy line information from regular cmd info.
*/
- for (i = 0; i < 2; i++) {
- if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- TclEmitPush(TclRegisterNewLiteral(envPtr,
- varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
- } else {
- SetLineInformation (i);
- code = TclCompileTokens(interp, varTokenPtr+1,
- varTokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- return code;
- }
- }
- varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
- }
+ bodyLines[i] = mapPtr->loc[eclIndex].line[valueIndex+1+i];
+ bodyNext[i] = mapPtr->loc[eclIndex].next[valueIndex+1+i];
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ }
- TclEmitOpcode(((((enum options) index) == STR_COMPARE) ?
- INST_STR_CMP : INST_STR_EQ), envPtr);
- return TCL_OK;
+ /*
+ * 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] == '-') {
+ ckfree((char *) bodyToken);
+ ckfree((char *) bodyLines);
+ ckfree((char *) bodyNext);
+ if (bodyTokenArray != NULL) {
+ ckfree((char *) bodyTokenArray);
}
- case STR_INDEX: {
- int i;
+ return TCL_ERROR;
+ }
- if (parsePtr->numWords != 4) {
- /* Fail at run time, not in compilation */
- return TCL_OUT_LINE_COMPILE;
- }
+ /*
+ * Now we commit to generating code; the parsing stage per se is done.
+ * First, we push the value we're matching against on the stack.
+ */
+
+ SetLineInformation (valueIndex);
+ CompileTokens(envPtr, valueTokenPtr, interp);
+
+ /*
+ * Check if we can generate a jump table, since if so that's faster than
+ * doing an explicit compare with each body. Note that we're definitely
+ * over-conservative with determining whether we can do the jump table,
+ * but it handles the most common case well enough.
+ */
+
+ if (mode == Switch_Exact) {
+ JumptableInfo *jtPtr;
+ int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation;
+ int mustGenerate, jumpToDefault;
+ Tcl_DString buffer;
+ Tcl_HashEntry *hPtr;
+ /*
+ * Compile the switch by using a jump table, which is basically a
+ * hashtable that maps from literal values to match against to the
+ * offset (relative to the INST_JUMP_TABLE instruction) to jump to.
+ * The jump table itself is independent of any invokation of the
+ * bytecode, and as such is stored in an auxData block.
+ *
+ * Start by allocating the jump table itself, plus some workspace.
+ */
+
+ jtPtr = (JumptableInfo *) ckalloc(sizeof(JumptableInfo));
+ Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);
+ infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr);
+ finalFixups = (int *) ckalloc(sizeof(int) * (numWords/2));
+ foundDefault = 0;
+ mustGenerate = 1;
+
+ /*
+ * Next, issue the instruction to do the jump, together with what we
+ * want to do if things do not work out (jump to either the default
+ * clause or the "default" default, which just sets the result to
+ * empty). Note that we will come back and rewrite the jump's offset
+ * parameter when we know what it should be, and that all jumps we
+ * issue are of the wide kind because that makes the code much easier
+ * to debug!
+ */
+
+ jumpLocation = CurrentOffset(envPtr);
+ TclEmitInstInt4(INST_JUMP_TABLE, infoIndex, envPtr);
+ jumpToDefault = CurrentOffset(envPtr);
+ TclEmitInstInt4(INST_JUMP4, 0, envPtr);
+
+ for (i=0 ; i<numWords ; i+=2) {
/*
- * Push the two operands onto the stack.
+ * For each arm, we must first work out what to do with the match
+ * term.
*/
- for (i = 0; i < 2; i++) {
- if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- TclEmitPush(TclRegisterNewLiteral(envPtr,
- varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
- } else {
- SetLineInformation (i);
- code = TclCompileTokens(interp, varTokenPtr+1,
- varTokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- return code;
- }
+ if (i!=numWords-2 || bodyToken[numWords-2]->size != 7 ||
+ memcmp(bodyToken[numWords-2]->start, "default", 7)) {
+ /*
+ * This is not a default clause, so insert the current
+ * location as a target in the jump table (assuming it isn't
+ * already there, which would indicate that this clause is
+ * probably masked by an earlier one). Note that we use a
+ * Tcl_DString here simply because the hash API does not let
+ * us specify the string length.
+ */
+
+ Tcl_DStringInit(&buffer);
+ Tcl_DStringAppend(&buffer, bodyToken[i]->start,
+ bodyToken[i]->size);
+ hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable,
+ Tcl_DStringValue(&buffer), &isNew);
+ if (isNew) {
+ /*
+ * First time we've encountered this match clause, so it
+ * must point to here.
+ */
+
+ Tcl_SetHashValue(hPtr, (ClientData)
+ (CurrentOffset(envPtr) - jumpLocation));
}
- varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
+ 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);
}
- TclEmitOpcode(INST_STR_INDEX, envPtr);
- return TCL_OK;
- }
- case STR_LENGTH: {
- if (parsePtr->numWords != 3) {
- /* Fail at run time, not in compilation */
- return TCL_OUT_LINE_COMPILE;
+ /*
+ * Now, for each arm we must deal with the body of the clause.
+ *
+ * If this is a continuation body (never true of a final clause,
+ * whether default or not) we're done because the next jump target
+ * will also point here, so we advance to the next clause.
+ */
+
+ if (bodyToken[i+1]->size == 1 && bodyToken[i+1]->start[0] == '-') {
+ mustGenerate = 1;
+ continue;
+ }
+
+ /*
+ * Also skip this arm if its only match clause is masked. (We
+ * could probably be more aggressive about this, but that would be
+ * much more difficult to get right.)
+ */
+
+ if (!isNew && !mustGenerate) {
+ continue;
}
+ mustGenerate = 0;
+
+ /*
+ * Compile the body of the arm.
+ */
+
+ envPtr->line = bodyLines[i+1]; /* TIP #280 */
+ envPtr->clNext = bodyNext[i+1]; /* TIP #280 */
+ TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
+
+ /*
+ * Compile a jump in to the end of the command if this body is
+ * anything other than a user-supplied default arm (to either skip
+ * over the remaining bodies or the code that generates an empty
+ * result).
+ */
+
+ if (i+2 < numWords || !foundDefault) {
+ finalFixups[numRealBodies++] = CurrentOffset(envPtr);
- if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
/*
- * Here someone is asking for the length of a static string.
- * Just push the actual character (not byte) length.
+ * Easier by far to issue this jump as a fixed-width jump.
+ * Otherwise we'd need to do a lot more (and more awkward)
+ * rewriting when we fixed this all up.
*/
- char buf[TCL_INTEGER_SPACE];
- int len = Tcl_NumUtfChars(varTokenPtr[1].start,
- varTokenPtr[1].size);
- len = sprintf(buf, "%d", len);
- TclEmitPush(TclRegisterNewLiteral(envPtr, buf, len), envPtr);
- return TCL_OK;
- } else {
- SetLineInformation (2);
- code = TclCompileTokens(interp, varTokenPtr+1,
- varTokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- return code;
- }
+
+ TclEmitInstInt4(INST_JUMP4, 0, envPtr);
}
- TclEmitOpcode(INST_STR_LEN, envPtr);
- return TCL_OK;
}
- case STR_MATCH: {
- int i, length, exactMatch = 0, nocase = 0;
- CONST char *str;
- if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
- /* Fail at run time, not in compilation */
- return TCL_OUT_LINE_COMPILE;
- }
+ /*
+ * 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 (parsePtr->numWords == 5) {
- if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_OUT_LINE_COMPILE;
- }
- str = varTokenPtr[1].start;
- length = varTokenPtr[1].size;
- if ((length > 1) &&
- strncmp(str, "-nocase", (size_t) length) == 0) {
- nocase = 1;
- } else {
- /* Fail at run time, not in compilation */
- return TCL_OUT_LINE_COMPILE;
- }
- varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
- }
+ if (!foundDefault) {
+ TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault,
+ envPtr->codeStart+jumpToDefault+1);
+ PushLiteral(envPtr, "", 0);
+ }
- for (i = 0; i < 2; i++) {
- if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- str = varTokenPtr[1].start;
- length = varTokenPtr[1].size;
- if (!nocase && (i == 0)) {
+ /*
+ * No more instructions to be issued; everything that needs to jump to
+ * the end of the command is fixed up at this point.
+ */
+
+ for (i=0 ; i<numRealBodies ; i++) {
+ TclStoreInt4AtPtr(CurrentOffset(envPtr)-finalFixups[i],
+ envPtr->codeStart+finalFixups[i]+1);
+ }
+
+ /*
+ * Clean up all our temporary space and return.
+ */
+
+ ckfree((char *) finalFixups);
+ ckfree((char *) bodyToken);
+ ckfree((char *) bodyLines);
+ ckfree((char *) bodyNext);
+ if (bodyTokenArray != NULL) {
+ ckfree((char *) bodyTokenArray);
+ }
+ return TCL_OK;
+ }
+
+ /*
+ * Generate a test for each arm.
+ */
+
+ contFixIndex = -1;
+ contFixCount = 0;
+ fixupArray = (JumpFixup *) ckalloc(sizeof(JumpFixup) * numWords);
+ fixupTargetArray = (int *) ckalloc(sizeof(int) * numWords);
+ memset(fixupTargetArray, 0, numWords * sizeof(int));
+ fixupCount = 0;
+ foundDefault = 0;
+ for (i=0 ; i<numWords ; i+=2) {
+ int nextArmFixupIndex = -1;
+
+ envPtr->currStackDepth = savedStackDepth + 1;
+ if (i!=numWords-2 || bodyToken[numWords-2]->size != 7 ||
+ memcmp(bodyToken[numWords-2]->start, "default", 7)) {
+ /*
+ * Generate the test for the arm.
+ */
+
+ switch (mode) {
+ case Switch_Exact:
+ TclEmitOpcode(INST_DUP, envPtr);
+ TclCompileTokens(interp, bodyToken[i], 1, envPtr);
+ TclEmitOpcode(INST_STR_EQ, envPtr);
+ break;
+ case Switch_Glob:
+ TclCompileTokens(interp, bodyToken[i], 1, envPtr);
+ TclEmitInstInt4(INST_OVER, 1, envPtr);
+ TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr);
+ break;
+ case Switch_Regexp: {
+ int simple = 0, exact = 0;
+
+ /*
+ * Keep in sync with TclCompileRegexpCmd.
+ */
+
+ if (bodyToken[i]->type == TCL_TOKEN_TEXT) {
+ Tcl_DString ds;
+
+ if (bodyToken[i]->size == 0) {
/*
- * On the first (pattern) arg, check to see if any
- * glob special characters are in the word '*[]?\\'.
- * If not, this is the same as 'string equal'. We
- * can use strpbrk here because the glob chars are all
- * in the ascii-7 range. If -nocase was specified,
- * we can't do this because INST_STR_EQ has no support
- * for nocase.
+ * The semantics of regexps are that they always match
+ * when the RE == "".
*/
- Tcl_Obj *copy = Tcl_NewStringObj(str, length);
- Tcl_IncrRefCount(copy);
- exactMatch = (strpbrk(Tcl_GetString(copy),
- "*[]?\\") == NULL);
- Tcl_DecrRefCount(copy);
+
+ PushLiteral(envPtr, "1", 1);
+ break;
}
- TclEmitPush(
- TclRegisterNewLiteral(envPtr, str, length), envPtr);
- } else {
- SetLineInformation (i);
- code = TclCompileTokens(interp, varTokenPtr+1,
- varTokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- return code;
+
+ /*
+ * Attempt to convert pattern to glob. If successful, push
+ * the converted pattern.
+ */
+
+ if (TclReToGlob(NULL, bodyToken[i]->start,
+ bodyToken[i]->size, &ds, &exact) == TCL_OK) {
+ simple = 1;
+ PushLiteral(envPtr, Tcl_DStringValue(&ds),
+ Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
+ }
+ }
+ if (!simple) {
+ TclCompileTokens(interp, bodyToken[i], 1, envPtr);
+ }
+
+ TclEmitInstInt4(INST_OVER, 1, envPtr);
+ if (simple) {
+ if (exact && !noCase) {
+ TclEmitOpcode(INST_STR_EQ, envPtr);
+ } else {
+ TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr);
}
+ } else {
+ /*
+ * Pass correct RE compile flags. We use only Int1
+ * (8-bit), but that handles all the flags we want to
+ * pass. Don't use TCL_REG_NOSUB as we may have backrefs
+ * or capture vars.
+ */
+
+ int cflags = TCL_REG_ADVANCED
+ | (noCase ? TCL_REG_NOCASE : 0);
+
+ TclEmitInstInt1(INST_REGEXP, cflags, envPtr);
}
- varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
+ break;
+ }
+ default:
+ Tcl_Panic("unknown switch mode: %d", mode);
}
- if (exactMatch) {
- TclEmitOpcode(INST_STR_EQ, envPtr);
- } else {
- TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
+ /*
+ * 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;
}
- return TCL_OK;
+
+ 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 = bodyNext[i+1]; /* TIP #280 */
+ TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
+
+ if (!foundDefault) {
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
+ fixupArray+fixupCount);
+ fixupCount++;
+ fixupTargetArray[nextArmFixupIndex] = CurrentOffset(envPtr);
+ }
+ }
+
+ /*
+ * Clean up all our temporary space and return.
+ */
+
+ ckfree((char *) bodyToken);
+ ckfree((char *) bodyLines);
+ ckfree((char *) bodyNext);
+ if (bodyTokenArray != NULL) {
+ ckfree((char *) bodyTokenArray);
+ }
+
+ /*
+ * Discard the value we are matching against unless we've had a default
+ * clause (in which case it will already be gone due to the code at the
+ * start of processing an arm, guaranteed) and make the result of the
+ * command an empty string.
+ */
+
+ if (!foundDefault) {
+ TclEmitOpcode(INST_POP, envPtr);
+ PushLiteral(envPtr, "", 0);
+ }
+
+ /*
+ * Do jump fixups for arms that were executed. First, fill in the jumps of
+ * all jumps that don't point elsewhere to point to here.
+ */
+
+ for (i=0 ; i<fixupCount ; i++) {
+ if (fixupTargetArray[i] == 0) {
+ fixupTargetArray[i] = envPtr->codeNext-envPtr->codeStart;
}
}
+ /*
+ * Now scan backwards over all the jumps (all of which are forward jumps)
+ * doing each one. When we do one and there is a size changes, we must
+ * scan back over all the previous ones and see if they need adjusting
+ * before proceeding with further jump fixups (the interleaved nature of
+ * all the jumps makes this impossible to do without nested loops).
+ */
+
+ for (i=fixupCount-1 ; i>=0 ; i--) {
+ if (TclFixupForwardJump(envPtr, &fixupArray[i],
+ fixupTargetArray[i] - fixupArray[i].codeOffset, 127)) {
+ int j;
+
+ for (j=i-1 ; j>=0 ; j--) {
+ if (fixupTargetArray[j] > fixupArray[i].codeOffset) {
+ fixupTargetArray[j] += 3;
+ }
+ }
+ }
+ }
+ ckfree((char *) fixupArray);
+ ckfree((char *) fixupTargetArray);
+
+ envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * TclCompileVariableCmd --
+ * DupJumptableInfo, FreeJumptableInfo --
*
- * Procedure called to reserve the local variables for the
- * "variable" command. The command itself is *not* compiled.
+ * Functions to duplicate, release and print a jump-table created for use
+ * with the INST_JUMP_TABLE instruction.
*
* Results:
- * Always returns TCL_OUT_LINE_COMPILE.
+ * DupJumptableInfo: a copy of the jump-table
+ * FreeJumptableInfo: none
+ * PrintJumptableInfo: none
*
* Side effects:
- * Indexed local variables are added to the environment.
+ * DupJumptableInfo: allocates memory
+ * FreeJumptableInfo: releases memory
+ * PrintJumptableInfo: none
*
*----------------------------------------------------------------------
*/
-int
-TclCompileVariableCmd(interp, parsePtr, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- Tcl_Parse *parsePtr; /* Points to a parse structure for the
- * command created by Tcl_ParseCommand. */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+
+static ClientData
+DupJumptableInfo(
+ ClientData clientData)
{
- Tcl_Token *varTokenPtr;
- int i, numWords;
- CONST char *varName, *tail;
-
- if (envPtr->procPtr == NULL) {
- return TCL_OUT_LINE_COMPILE;
+ 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;
+}
- numWords = parsePtr->numWords;
-
- varTokenPtr = parsePtr->tokenPtr
- + (parsePtr->tokenPtr->numComponents + 1);
- for (i = 1; i < numWords; i += 2) {
- if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- varName = varTokenPtr[1].start;
- tail = varName + varTokenPtr[1].size - 1;
- if ((*tail == ')') || (tail < varName)) continue;
- while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) {
- tail--;
- }
- if ((*tail == ':') && (tail > varName)) {
- tail++;
+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);
}
- (void) TclFindCompiledLocal(tail, (tail-varName+1),
- /*create*/ 1, /*flags*/ 0, envPtr->procPtr);
- varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
}
+ Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %d",
+ keyPtr, pcOffset + offset);
}
- return TCL_OUT_LINE_COMPILE;
}
/*
@@ -3000,99 +4674,87 @@ TclCompileVariableCmd(interp, parsePtr, envPtr)
* Procedure called to compile the "while" command.
*
* Results:
- * The return value is a standard Tcl result, which is TCL_OK if
- * compilation was successful. If an error occurs then the
- * interpreter's result contains a standard error message and TCL_ERROR
- * is returned. If compilation failed because the command is too
- * complex for TclCompileWhileCmd, TCL_OUT_LINE_COMPILE is returned
- * indicating that the while command should be compiled "out of line"
- * by emitting code to invoke its command procedure at runtime.
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
*
* Side effects:
- * Instructions are added to envPtr to execute the "while" command
- * at runtime.
+ * Instructions are added to envPtr to execute the "while" command at
+ * runtime.
*
*----------------------------------------------------------------------
*/
int
-TclCompileWhileCmd(interp, parsePtr, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- Tcl_Parse *parsePtr; /* Points to a parse structure for the
- * command created by Tcl_ParseCommand. */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+TclCompileWhileCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *testTokenPtr, *bodyTokenPtr;
JumpFixup jumpEvalCondFixup;
- int testCodeOffset, bodyCodeOffset, jumpDist;
- int range, code;
- char buffer[32 + TCL_INTEGER_SPACE];
+ 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. */
+ int loopMayEnd = 1; /* This is set to 0 if it is recognized as an
+ * infinite loop. */
Tcl_Obj *boolObj;
- int boolVal;
-
- DefineLineInformation;
+ DefineLineInformation; /* TIP #280 */
if (parsePtr->numWords != 3) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"while test command\"", -1);
return TCL_ERROR;
}
/*
- * If the test expression requires substitutions, don't compile the
- * while command inline. E.g., the expression might cause the loop to
- * never execute or execute forever, as in "while "$x < 5" {}".
+ * If the test expression requires substitutions, don't compile the while
+ * command inline. E.g., the expression might cause the loop to never
+ * execute or execute forever, as in "while "$x < 5" {}".
*
- * Bail out also if the body expression requires substitutions
- * in order to insure correct behaviour [Bug 219166]
+ * Bail out also if the body expression requires substitutions in order to
+ * insure correct behaviour [Bug 219166]
*/
- testTokenPtr = parsePtr->tokenPtr
- + (parsePtr->tokenPtr->numComponents + 1);
- bodyTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
+ testTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ bodyTokenPtr = TokenAfter(testTokenPtr);
+
if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
|| (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
- return TCL_OUT_LINE_COMPILE;
+ return TCL_ERROR;
}
/*
- * Find out if the condition is a constant.
+ * Find out if the condition is a constant.
*/
boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size);
Tcl_IncrRefCount(boolObj);
code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
- Tcl_DecrRefCount(boolObj);
+ TclDecrRefCount(boolObj);
if (code == TCL_OK) {
if (boolVal) {
/*
- * it is an infinite loop
+ * It is an infinite loop; flag it so that we generate a more
+ * efficient body.
*/
- loopMayEnd = 0;
+ loopMayEnd = 0;
} else {
/*
- * This is an empty loop: "while 0 {...}" or such.
- * Compile no bytecodes.
+ * This is an empty loop: "while 0 {...}" or such. Compile no
+ * bytecodes.
*/
goto pushResult;
}
}
- /*
+ /*
* Create a ExceptionRange record for the loop body. This is used to
* implement break and continue.
*/
- envPtr->exceptDepth++;
- envPtr->maxExceptDepth =
- TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
- range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
+ range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
/*
* Jump to the evaluation of the condition. This code uses the "loop
@@ -3110,31 +4772,26 @@ TclCompileWhileCmd(interp, parsePtr, envPtr)
if (loopMayEnd) {
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);
- testCodeOffset = 0; /* avoid compiler warning */
+ testCodeOffset = 0; /* Avoid compiler warning. */
} else {
- testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
+ /*
+ * Make sure that the first command in the body is preceded by an
+ * INST_START_CMD, and hence counted properly. [Bug 1752146]
+ */
+
+ envPtr->atCmdStart = 0;
+ testCodeOffset = CurrentOffset(envPtr);
}
-
/*
* Compile the loop body.
*/
SetLineInformation (2);
- bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart);
- code = TclCompileCmdWord(interp, bodyTokenPtr+1,
- bodyTokenPtr->numComponents, envPtr);
+ bodyCodeOffset = ExceptionRangeStarts(envPtr, range);
+ CompileBody(envPtr, bodyTokenPtr, interp);
+ ExceptionRangeEnds(envPtr, range);
envPtr->currStackDepth = savedStackDepth + 1;
- if (code != TCL_OK) {
- if (code == TCL_ERROR) {
- sprintf(buffer, "\n (\"while\" body line %d)",
- interp->errorLine);
- Tcl_AddObjErrorInfo(interp, buffer, -1);
- }
- goto error;
- }
- envPtr->exceptArrayPtr[range].numCodeBytes =
- (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
TclEmitOpcode(INST_POP, envPtr);
/*
@@ -3143,7 +4800,7 @@ TclCompileWhileCmd(interp, parsePtr, envPtr)
*/
if (loopMayEnd) {
- testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
+ testCodeOffset = CurrentOffset(envPtr);
jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
bodyCodeOffset += 3;
@@ -3151,113 +4808,86 @@ TclCompileWhileCmd(interp, parsePtr, envPtr)
}
envPtr->currStackDepth = savedStackDepth;
SetLineInformation (1);
- code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
- if (code != TCL_OK) {
- if (code == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp,
- "\n (\"while\" test expression)", -1);
- }
- goto error;
- }
+ TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
envPtr->currStackDepth = savedStackDepth + 1;
-
- jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
+
+ jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
if (jumpDist > 127) {
TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
} else {
TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
}
} else {
- jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
+ jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
if (jumpDist > 127) {
TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr);
} else {
TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr);
- }
+ }
}
-
/*
* Set the loop's body, continue and break offsets.
*/
envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset;
- envPtr->exceptArrayPtr[range].breakOffset =
- (envPtr->codeNext - envPtr->codeStart);
-
+ ExceptionRangeTarget(envPtr, range, breakOffset);
+
/*
* The while command's result is an empty string.
*/
- pushResult:
+ pushResult:
envPtr->currStackDepth = savedStackDepth;
- TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
- envPtr->exceptDepth--;
+ PushLiteral(envPtr, "", 0);
return TCL_OK;
-
- error:
- envPtr->exceptDepth--;
- return code;
}
/*
*----------------------------------------------------------------------
*
- * TclPushVarName --
+ * PushVarName --
*
- * Procedure used in the compiling where pushing a variable name
- * is necessary (append, lappend, set).
+ * Procedure used in the compiling where pushing a variable name is
+ * necessary (append, lappend, set).
*
* Results:
- * The return value is a standard Tcl result, which is normally TCL_OK
- * unless there was an error while parsing string. If an error occurs
- * then the interpreter's result contains a standard error message.
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
*
* Side effects:
- * Instructions are added to envPtr to execute the "set" command
- * at runtime.
+ * Instructions are added to envPtr to execute the "set" command at
+ * runtime.
*
*----------------------------------------------------------------------
*/
static int
-TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr,
-#ifndef TCL_TIP280
- simpleVarNamePtr, isScalarPtr)
-#else
- simpleVarNamePtr, isScalarPtr, line, clNext)
-#endif
- Tcl_Interp *interp; /* Used for error reporting. */
- Tcl_Token *varTokenPtr; /* Points to a variable token. */
- CompileEnv *envPtr; /* Holds resulting instructions. */
- int flags; /* takes TCL_CREATE_VAR or
- * TCL_NO_LARGE_INDEX */
- int *localIndexPtr; /* must not be NULL */
- int *simpleVarNamePtr; /* must not be NULL */
- int *isScalarPtr; /* must not be NULL */
-#ifdef TCL_TIP280
- int line; /* line the token starts on */
- int* clNext;
-#endif
-{
- register CONST char *p;
- CONST char *name, *elName;
+PushVarName(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Token *varTokenPtr, /* Points to a variable token. */
+ CompileEnv *envPtr, /* Holds resulting instructions. */
+ int flags, /* TCL_CREATE_VAR or TCL_NO_LARGE_INDEX. */
+ int *localIndexPtr, /* Must not be NULL. */
+ int *simpleVarNamePtr, /* Must not be NULL. */
+ int *isScalarPtr, /* Must not be NULL. */
+ int line, /* Line the token starts on. */
+ int* clNext) /* Reference to offset of next hidden cont. line */
+{
+ register const char *p;
+ const char *name, *elName;
register int i, n;
- int nameChars, elNameChars, simpleVarName, localIndex;
- int code = TCL_OK;
-
Tcl_Token *elemTokenPtr = NULL;
- int elemTokenCount = 0;
- int allocedTokens = 0;
- int removedParen = 0;
+ int nameChars, elNameChars, simpleVarName, localIndex;
+ int elemTokenCount = 0, allocedTokens = 0, removedParen = 0;
/*
- * 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.
+ * 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.
*/
simpleVarName = 0;
@@ -3267,8 +4897,8 @@ TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr,
/*
* Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether
- * curly braces surround the variable name.
- * This really matters for array elements to handle things like
+ * curly braces surround the variable name. This really matters for array
+ * elements to handle things like
* set {x($foo)} 5
* which raises an undefined var error if we are not careful here.
*/
@@ -3279,31 +4909,33 @@ TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr,
* A simple variable name. Divide it up into "name" and "elName"
* strings. If it is not a local variable, look it up at runtime.
*/
+
simpleVarName = 1;
name = varTokenPtr[1].start;
nameChars = varTokenPtr[1].size;
- if ( *(name + nameChars - 1) == ')') {
- /*
+ if (name[nameChars-1] == ')') {
+ /*
* last char is ')' => potential array reference.
*/
- for (i = 0, p = name; i < nameChars; i++, p++) {
+ for (i=0,p=name ; i<nameChars ; i++,p++) {
if (*p == '(') {
elName = p + 1;
elNameChars = nameChars - i - 2;
- nameChars = i ;
+ nameChars = i;
break;
}
}
if ((elName != NULL) && elNameChars) {
/*
- * An array element, the element name is a simple
- * string: assemble the corresponding token.
+ * An array element, the element name is a simple string:
+ * assemble the corresponding token.
*/
- elemTokenPtr = (Tcl_Token *) ckalloc(sizeof(Tcl_Token));
+ elemTokenPtr = (Tcl_Token *) TclStackAlloc(interp,
+ sizeof(Tcl_Token));
allocedTokens = 1;
elemTokenPtr->type = TCL_TOKEN_TEXT;
elemTokenPtr->start = elName;
@@ -3314,28 +4946,28 @@ TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr,
}
} else if (((n = varTokenPtr->numComponents) > 1)
&& (varTokenPtr[1].type == TCL_TOKEN_TEXT)
- && (varTokenPtr[n].type == TCL_TOKEN_TEXT)
- && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) {
+ && (varTokenPtr[n].type == TCL_TOKEN_TEXT)
+ && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) {
- /*
- * Check for parentheses inside first token
+ /*
+ * Check for parentheses inside first token.
*/
- simpleVarName = 0;
- for (i = 0, p = varTokenPtr[1].start;
- i < varTokenPtr[1].size; i++, p++) {
- if (*p == '(') {
- simpleVarName = 1;
- break;
- }
- }
- if (simpleVarName) {
+ simpleVarName = 0;
+ for (i = 0, p = varTokenPtr[1].start;
+ i < varTokenPtr[1].size; i++, p++) {
+ if (*p == '(') {
+ simpleVarName = 1;
+ break;
+ }
+ }
+ if (simpleVarName) {
int remainingChars;
/*
- * Check the last token: if it is just ')', do not count
- * it. Otherwise, remove the ')' and flag so that it is
- * restored at the end.
+ * Check the last token: if it is just ')', do not count it.
+ * Otherwise, remove the ')' and flag so that it is restored at
+ * the end.
*/
if (varTokenPtr[n].size == 1) {
@@ -3345,39 +4977,40 @@ TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr,
removedParen = n;
}
- name = varTokenPtr[1].start;
- nameChars = p - varTokenPtr[1].start;
- elName = p + 1;
- remainingChars = (varTokenPtr[2].start - p) - 1;
- elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2;
+ name = varTokenPtr[1].start;
+ nameChars = p - varTokenPtr[1].start;
+ elName = p + 1;
+ remainingChars = (varTokenPtr[2].start - p) - 1;
+ elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2;
if (remainingChars) {
/*
- * Make a first token with the extra characters in the first
+ * Make a first token with the extra characters in the first
* token.
*/
- elemTokenPtr = (Tcl_Token *) ckalloc(n * sizeof(Tcl_Token));
+ elemTokenPtr = (Tcl_Token *) TclStackAlloc(interp,
+ n * sizeof(Tcl_Token));
allocedTokens = 1;
elemTokenPtr->type = TCL_TOKEN_TEXT;
elemTokenPtr->start = elName;
elemTokenPtr->size = remainingChars;
elemTokenPtr->numComponents = 0;
elemTokenCount = n;
-
+
/*
* Copy the remaining tokens.
*/
-
- memcpy((void *) (elemTokenPtr+1), (void *) (&varTokenPtr[2]),
- ((n-1) * sizeof(Tcl_Token)));
+
+ memcpy(elemTokenPtr+1, varTokenPtr+2,
+ (n-1) * sizeof(Tcl_Token));
} else {
/*
* Use the already available tokens.
*/
-
+
elemTokenPtr = &varTokenPtr[2];
- elemTokenCount = n - 1;
+ elemTokenCount = n - 1;
}
}
}
@@ -3396,23 +5029,25 @@ TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr,
}
/*
- * Look up the var name's index in the array of local vars in the
- * proc frame. If retrieving the var's value and it doesn't already
- * exist, push its name and look it up at runtime.
+ * Look up the var name's index in the array of local vars in the proc
+ * frame. If retrieving the var's value and it doesn't already exist,
+ * push its name and look it up at runtime.
*/
if ((envPtr->procPtr != NULL) && !hasNsQualifiers) {
localIndex = TclFindCompiledLocal(name, nameChars,
- /*create*/ (flags & TCL_CREATE_VAR),
- /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY),
+ /*create*/ flags & TCL_CREATE_VAR,
envPtr->procPtr);
if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
- /* we'll push the name */
+ /*
+ * We'll push the name.
+ */
+
localIndex = -1;
}
}
if (localIndex < 0) {
- TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameChars), envPtr);
+ PushLiteral(envPtr, name, nameChars);
}
/*
@@ -3421,17 +5056,11 @@ TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr,
if (elName != NULL) {
if (elNameChars) {
-#ifdef TCL_TIP280
- envPtr->line = line;
- envPtr->clNext = clNext;
-#endif
- code = TclCompileTokens(interp, elemTokenPtr,
- elemTokenCount, envPtr);
- if (code != TCL_OK) {
- goto done;
- }
+ envPtr->line = line;
+ envPtr->clNext = clNext;
+ TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr);
} else {
- TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
+ PushLiteral(envPtr, "", 0);
}
}
} else {
@@ -3439,28 +5068,1406 @@ TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr,
* The var name isn't simple: compile and push it.
*/
-#ifdef TCL_TIP280
- envPtr->line = line;
- envPtr->clNext = clNext;
-#endif
- code = TclCompileTokens(interp, varTokenPtr+1,
- varTokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- goto done;
- }
+ envPtr->line = line;
+ envPtr->clNext = clNext;
+ CompileTokens(envPtr, varTokenPtr, interp);
}
- done:
if (removedParen) {
++varTokenPtr[removedParen].size;
}
if (allocedTokens) {
- ckfree((char *) elemTokenPtr);
+ TclStackFree(interp, elemTokenPtr);
}
- *localIndexPtr = localIndex;
- *simpleVarNamePtr = simpleVarName;
- *isScalarPtr = (elName == NULL);
- return code;
+ *localIndexPtr = localIndex;
+ *simpleVarNamePtr = simpleVarName;
+ *isScalarPtr = (elName == NULL);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileUnaryOpCmd --
+ *
+ * Utility routine to compile the unary operator commands.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the compiled command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileUnaryOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ int instruction,
+ CompileEnv *envPtr)
+{
+ Tcl_Token *tokenPtr;
+ DefineLineInformation; /* TIP #280 */
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ TclEmitOpcode(instruction, envPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileAssociativeBinaryOpCmd --
+ *
+ * Utility routine to compile the binary operator commands that accept an
+ * arbitrary number of arguments, and that are associative operations.
+ * Because of the associativity, we may combine operations from right to
+ * left, saving us any effort of re-ordering the arguments on the stack
+ * after substitutions are completed.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the compiled command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileAssociativeBinaryOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ const char *identity,
+ int instruction,
+ CompileEnv *envPtr)
+{
+ Tcl_Token *tokenPtr = parsePtr->tokenPtr;
+ DefineLineInformation; /* TIP #280 */
+ int words;
+
+ for (words=1 ; words<parsePtr->numWords ; words++) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, words);
+ }
+ if (parsePtr->numWords <= 2) {
+ PushLiteral(envPtr, identity, -1);
+ words++;
+ }
+ if (words > 3) {
+ /*
+ * Reverse order of arguments to get precise agreement with
+ * [expr] in calcuations, including roundoff errors.
+ */
+ TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
+ }
+ while (--words > 1) {
+ TclEmitOpcode(instruction, envPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileStrictlyBinaryOpCmd --
+ *
+ * Utility routine to compile the binary operator commands, that strictly
+ * accept exactly two arguments.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the compiled command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileStrictlyBinaryOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ int instruction,
+ CompileEnv *envPtr)
+{
+ if (parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+ return CompileAssociativeBinaryOpCmd(interp, parsePtr,
+ NULL, instruction, envPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileComparisonOpCmd --
+ *
+ * Utility routine to compile the n-ary comparison operator commands.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the compiled command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileComparisonOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ int instruction,
+ CompileEnv *envPtr)
+{
+ Tcl_Token *tokenPtr;
+ DefineLineInformation; /* TIP #280 */
+
+ if (parsePtr->numWords < 3) {
+ PushLiteral(envPtr, "1", 1);
+ } else if (parsePtr->numWords == 3) {
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ TclEmitOpcode(instruction, envPtr);
+ } else if (envPtr->procPtr == NULL) {
+ /*
+ * No local variable space!
+ */
+
+ return TCL_ERROR;
+ } else {
+ int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr->procPtr);
+ int words;
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ if (tmpIndex <= 255) {
+ TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
+ } else {
+ TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
+ }
+ TclEmitOpcode(instruction, envPtr);
+ for (words=3 ; words<parsePtr->numWords ;) {
+ if (tmpIndex <= 255) {
+ TclEmitInstInt1(INST_LOAD_SCALAR1, tmpIndex, envPtr);
+ } else {
+ TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr);
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, words);
+ if (++words < parsePtr->numWords) {
+ if (tmpIndex <= 255) {
+ TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
+ } else {
+ TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
+ }
+ }
+ TclEmitOpcode(instruction, envPtr);
+ }
+ for (; words>3 ; words--) {
+ TclEmitOpcode(INST_BITAND, envPtr);
+ }
+
+ /*
+ * Drop the value from the temp variable; retaining that reference
+ * might be expensive elsewhere.
+ */
+
+ PushLiteral(envPtr, "", 0);
+ if (tmpIndex <= 255) {
+ TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
+ } else {
+ TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
+ }
+ TclEmitOpcode(INST_POP, envPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompile*OpCmd --
+ *
+ * Procedures called to compile the corresponding "::tcl::mathop::*"
+ * commands. These are all wrappers around the utility operator command
+ * compiler functions, except for the compilers for subtraction and
+ * division, which are special.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the compiled command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileInvertOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileUnaryOpCmd(interp, parsePtr, INST_BITNOT, envPtr);
+}
+
+int
+TclCompileNotOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileUnaryOpCmd(interp, parsePtr, INST_LNOT, envPtr);
+}
+
+int
+TclCompileAddOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_ADD,
+ envPtr);
+}
+
+int
+TclCompileMulOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileAssociativeBinaryOpCmd(interp, parsePtr, "1", INST_MULT,
+ envPtr);
+}
+
+int
+TclCompileAndOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileAssociativeBinaryOpCmd(interp, parsePtr, "-1", INST_BITAND,
+ envPtr);
+}
+
+int
+TclCompileOrOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITOR,
+ envPtr);
+}
+
+int
+TclCompileXorOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITXOR,
+ envPtr);
+}
+
+int
+TclCompilePowOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ /*
+ * This one has its own implementation because the ** operator is
+ * the only one with right associativity.
+ */
+ Tcl_Token *tokenPtr = parsePtr->tokenPtr;
+ DefineLineInformation; /* TIP #280 */
+ int words;
+
+ for (words=1 ; words<parsePtr->numWords ; words++) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, words);
+ }
+ if (parsePtr->numWords <= 2) {
+ PushLiteral(envPtr, "1", 1);
+ words++;
+ }
+ while (--words > 1) {
+ TclEmitOpcode(INST_EXPON, envPtr);
+ }
+ return TCL_OK;
+}
+
+int
+TclCompileLshiftOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LSHIFT, envPtr);
+}
+
+int
+TclCompileRshiftOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_RSHIFT, envPtr);
+}
+
+int
+TclCompileModOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_MOD, envPtr);
+}
+
+int
+TclCompileNeqOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_NEQ, envPtr);
+}
+
+int
+TclCompileStrneqOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_STR_NEQ, envPtr);
+}
+
+int
+TclCompileInOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_IN, envPtr);
+}
+
+int
+TclCompileNiOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_NOT_IN,
+ envPtr);
+}
+
+int
+TclCompileLessOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileComparisonOpCmd(interp, parsePtr, INST_LT, envPtr);
+}
+
+int
+TclCompileLeqOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileComparisonOpCmd(interp, parsePtr, INST_LE, envPtr);
+}
+
+int
+TclCompileGreaterOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileComparisonOpCmd(interp, parsePtr, INST_GT, envPtr);
+}
+
+int
+TclCompileGeqOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileComparisonOpCmd(interp, parsePtr, INST_GE, envPtr);
+}
+
+int
+TclCompileEqOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileComparisonOpCmd(interp, parsePtr, INST_EQ, envPtr);
+}
+
+int
+TclCompileStreqOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ return CompileComparisonOpCmd(interp, parsePtr, INST_STR_EQ, envPtr);
+}
+
+int
+TclCompileMinusOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ Tcl_Token *tokenPtr = parsePtr->tokenPtr;
+ DefineLineInformation; /* TIP #280 */
+ int words;
+
+ if (parsePtr->numWords == 1) {
+ /* Fallback to direct eval to report syntax error */
+ return TCL_ERROR;
+ }
+ for (words=1 ; words<parsePtr->numWords ; words++) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, words);
+ }
+ if (words == 2) {
+ TclEmitOpcode(INST_UMINUS, envPtr);
+ return TCL_OK;
+ }
+ if (words == 3) {
+ TclEmitOpcode(INST_SUB, envPtr);
+ return TCL_OK;
+ }
+ /*
+ * Reverse order of arguments to get precise agreement with
+ * [expr] in calcuations, including roundoff errors.
+ */
+ TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
+ while (--words > 1) {
+ TclEmitInstInt4(INST_REVERSE, 2, envPtr);
+ TclEmitOpcode(INST_SUB, envPtr);
+ }
+ return TCL_OK;
+}
+
+int
+TclCompileDivOpCmd(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ Tcl_Token *tokenPtr = parsePtr->tokenPtr;
+ DefineLineInformation; /* TIP #280 */
+ int words;
+
+ if (parsePtr->numWords == 1) {
+ /* Fallback to direct eval to report syntax error */
+ return TCL_ERROR;
+ }
+ if (parsePtr->numWords == 2) {
+ PushLiteral(envPtr, "1.0", 3);
+ }
+ for (words=1 ; words<parsePtr->numWords ; words++) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, words);
+ }
+ if (words <= 3) {
+ TclEmitOpcode(INST_DIV, envPtr);
+ return TCL_OK;
+ }
+ /*
+ * Reverse order of arguments to get precise agreement with
+ * [expr] in calcuations, including roundoff errors.
+ */
+ TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
+ while (--words > 1) {
+ TclEmitInstInt4(INST_REVERSE, 2, envPtr);
+ TclEmitOpcode(INST_DIV, envPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * IndexTailVarIfKnown --
+ *
+ * Procedure used in compiling [global] and [variable] commands. It
+ * inspects the variable name described by varTokenPtr and, if the tail
+ * is known at compile time, defines a corresponding local variable.
+ *
+ * Results:
+ * Returns the variable's index in the table of compiled locals if the
+ * tail is known at compile time, or -1 otherwise.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+IndexTailVarIfKnown(
+ Tcl_Interp *interp,
+ Tcl_Token *varTokenPtr, /* Token representing the variable name */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Obj *tailPtr;
+ const char *tailName, *p;
+ int len, n = varTokenPtr->numComponents;
+ Tcl_Token *lastTokenPtr;
+ int full, localIndex;
+
+ /*
+ * Determine if the tail is (a) known at compile time, and (b) not an
+ * array element. Should any of these fail, return an error so that
+ * the non-compiled command will be called at runtime.
+ * In order for the tail to be known at compile time, the last token
+ * in the word has to be constant and contain "::" if it is not the
+ * only one.
+ */
+
+ if (envPtr->procPtr == NULL) {
+ return -1;
+ }
+
+ TclNewObj(tailPtr);
+ if (TclWordKnownAtCompileTime(varTokenPtr, tailPtr)) {
+ full = 1;
+ lastTokenPtr = varTokenPtr;
+ } else {
+ full = 0;
+ lastTokenPtr = varTokenPtr + n;
+ if (!TclWordKnownAtCompileTime(lastTokenPtr, tailPtr)) {
+ Tcl_DecrRefCount(tailPtr);
+ return -1;
+ }
+ }
+
+ tailName = TclGetStringFromObj(tailPtr, &len);
+
+ if (len) {
+ if (*(tailName+len-1) == ')') {
+ /*
+ * Possible array: bail out
+ */
+
+ Tcl_DecrRefCount(tailPtr);
+ return -1;
+ }
+
+ /*
+ * Get the tail: immediately after the last '::'
+ */
+
+ for(p = tailName + len -1; p > tailName; p--) {
+ if ((*p == ':') && (*(p-1) == ':')) {
+ p++;
+ break;
+ }
+ }
+ if (!full && (p == tailName)) {
+ /*
+ * No :: in the last component
+ */
+ Tcl_DecrRefCount(tailPtr);
+ return -1;
+ }
+ len -= p - tailName;
+ tailName = p;
+ }
+
+ localIndex = TclFindCompiledLocal(tailName, len,
+ /*create*/ TCL_CREATE_VAR,
+ envPtr->procPtr);
+ Tcl_DecrRefCount(tailPtr);
+ return localIndex;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileUpvarCmd --
+ *
+ * Procedure called to compile the "upvar" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "upvar" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileUpvarCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
+ int 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;
+ 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, TCL_CREATE_VAR,
+ &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, TCL_CREATE_VAR,
+ &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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileEnsemble --
+ *
+ * Procedure called to compile an ensemble command. Note that most
+ * ensembles are not compiled, since modifying a compiled ensemble causes
+ * a invalidation of all existing bytecode (expensive!) which is not
+ * normally warranted.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the subcommands of the
+ * ensemble at runtime if a compile-time mapping is possible.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileEnsemble(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr;
+ Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
+ Tcl_Command ensemble = (Tcl_Command) cmdPtr;
+ Tcl_Parse synthetic;
+ int len, numBytes, result, flags = 0, i;
+ const char *word;
+
+ if (parsePtr->numWords < 2) {
+ return TCL_ERROR;
+ }
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ /*
+ * Too hard.
+ */
+
+ return TCL_ERROR;
+ }
+
+ word = tokenPtr[1].start;
+ numBytes = tokenPtr[1].size;
+
+ /*
+ * There's a sporting chance we'll be able to compile this. But now we
+ * must check properly. To do that, check that we're compiling an ensemble
+ * that has a compilable command as its appropriate subcommand.
+ */
+
+ if (Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj) != TCL_OK
+ || mapObj == NULL) {
+ /*
+ * Either not an ensemble or a mapping isn't installed. Crud. Too hard
+ * to proceed.
+ */
+
+ return TCL_ERROR;
+ }
+
+ /*
+ * Next, get the flags. We need them on several code paths.
+ */
+
+ (void) Tcl_GetEnsembleFlags(NULL, ensemble, &flags);
+
+ /*
+ * Check to see if there's also a subcommand list; must check to see if
+ * the subcommand we are calling is in that list if it exists, since that
+ * list filters the entries in the map.
+ */
+
+ (void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj);
+ if (listObj != NULL) {
+ int sclen;
+ const char *str;
+ Tcl_Obj *matchObj = NULL;
+
+ if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ for (i=0 ; i<len ; i++) {
+ str = Tcl_GetStringFromObj(elems[i], &sclen);
+ if (sclen==numBytes && !memcmp(word, str, (unsigned) numBytes)) {
+ /*
+ * Exact match! Excellent!
+ */
+
+ result = Tcl_DictObjGet(NULL, mapObj,elems[i], &targetCmdObj);
+ if (result != TCL_OK || targetCmdObj == NULL) {
+ return TCL_ERROR;
+ }
+ goto doneMapLookup;
+ }
+
+ /*
+ * Check to see if we've got a prefix match. A single prefix match
+ * is fine, and allows us to refine our dictionary lookup, but
+ * multiple prefix matches is a Bad Thing and will prevent us from
+ * making progress. Note that we cannot do the lookup immediately
+ * in the prefix case; might be another entry later in the list
+ * that causes things to fail.
+ */
+
+ if ((flags & TCL_ENSEMBLE_PREFIX)
+ && strncmp(word, str, (unsigned) numBytes) == 0) {
+ if (matchObj != NULL) {
+ return TCL_ERROR;
+ }
+ matchObj = elems[i];
+ }
+ }
+ if (matchObj != NULL) {
+ result = Tcl_DictObjGet(NULL, mapObj, matchObj, &targetCmdObj);
+ if (result != TCL_OK || targetCmdObj == NULL) {
+ return TCL_ERROR;
+ }
+ goto doneMapLookup;
+ }
+ return TCL_ERROR;
+ } else {
+ /*
+ * No map, so check the dictionary directly.
+ */
+
+ TclNewStringObj(subcmdObj, word, numBytes);
+ result = Tcl_DictObjGet(NULL, mapObj, subcmdObj, &targetCmdObj);
+ TclDecrRefCount(subcmdObj);
+ if (result == TCL_OK && targetCmdObj != NULL) {
+ /*
+ * Got it. Skip the fiddling around with prefixes.
+ */
+
+ goto doneMapLookup;
+ }
+
+ /*
+ * We've not literally got a valid subcommand. But maybe we have a
+ * prefix. Check if prefix matches are allowed.
+ */
+
+ if (flags & TCL_ENSEMBLE_PREFIX) {
+ Tcl_DictSearch s;
+ int done, matched;
+ Tcl_Obj *tmpObj;
+
+ /*
+ * Iterate over the keys in the dictionary, checking to see if
+ * we're a prefix.
+ */
+
+ Tcl_DictObjFirst(NULL,mapObj,&s,&subcmdObj,&tmpObj,&done);
+ matched = 0;
+ while (!done) {
+ if (strncmp(TclGetString(subcmdObj), word,
+ (unsigned) numBytes) == 0) {
+ if (matched++) {
+ /*
+ * Must have matched twice! Not unique, so no point
+ * looking further.
+ */
+
+ break;
+ }
+ targetCmdObj = tmpObj;
+ }
+ Tcl_DictObjNext(&s, &subcmdObj, &tmpObj, &done);
+ }
+ Tcl_DictObjDone(&s);
+
+ /*
+ * If we have anything other than a single match, we've failed the
+ * unique prefix check.
+ */
+
+ if (matched != 1) {
+ return TCL_ERROR;
+ }
+ } else {
+ return TCL_ERROR;
+ }
+ }
+
+ /*
+ * OK, we definitely map to something. But what?
+ *
+ * The command we map to is the first word out of the map element. Note
+ * that we also reject dealing with multi-element rewrites if we are in a
+ * safe interpreter, as there is otherwise a (highly gnarly!) way to make
+ * Tcl crash open to exploit.
+ */
+
+ doneMapLookup:
+ if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (len > 1 && Tcl_IsSafe(interp)) {
+ return TCL_ERROR;
+ }
+ targetCmdObj = elems[0];
+
+ Tcl_IncrRefCount(targetCmdObj);
+ cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj);
+ TclDecrRefCount(targetCmdObj);
+ if (cmdPtr == NULL || cmdPtr->compileProc == NULL
+ || cmdPtr->flags & CMD_HAS_EXEC_TRACES
+ || ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) {
+ /*
+ * Maps to an undefined command or a command without a compiler.
+ * Cannot compile.
+ */
+
+ return TCL_ERROR;
+ }
+
+ /*
+ * Now we've done the mapping process, can now actually try to compile.
+ * We do this by handing off to the subcommand's actual compiler. But to
+ * do that, we have to perform some trickery to rewrite the arguments.
+ */
+
+ TclParseInit(interp, NULL, 0, &synthetic);
+ synthetic.numWords = parsePtr->numWords - 2 + len;
+ TclGrowParseTokenArray(&synthetic, 2*len);
+ synthetic.numTokens = 2*len;
+
+ /*
+ * Now we have the space to work in, install something rewritten. Note
+ * that we are here praying for all our might that none of these words are
+ * a script; the error detection code will crash if that happens and there
+ * is nothing we can do to avoid it!
+ */
+
+ for (i=0 ; i<len ; i++) {
+ int sclen;
+ const char *str = Tcl_GetStringFromObj(elems[i], &sclen);
+
+ synthetic.tokenPtr[2*i].type = TCL_TOKEN_SIMPLE_WORD;
+ synthetic.tokenPtr[2*i].start = str;
+ synthetic.tokenPtr[2*i].size = sclen;
+ synthetic.tokenPtr[2*i].numComponents = 1;
+
+ synthetic.tokenPtr[2*i+1].type = TCL_TOKEN_TEXT;
+ synthetic.tokenPtr[2*i+1].start = str;
+ synthetic.tokenPtr[2*i+1].size = sclen;
+ synthetic.tokenPtr[2*i+1].numComponents = 0;
+ }
+
+ /*
+ * Copy over the real argument tokens.
+ */
+
+ for (i=len; i<synthetic.numWords; i++) {
+ int toCopy;
+ tokenPtr = TokenAfter(tokenPtr);
+ toCopy = tokenPtr->numComponents + 1;
+ TclGrowParseTokenArray(&synthetic, toCopy);
+ memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr,
+ sizeof(Tcl_Token) * toCopy);
+ synthetic.numTokens += toCopy;
+ }
+
+ /*
+ * Hand off compilation to the subcommand compiler. At last!
+ */
+
+ result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr);
+
+ /*
+ * Clean up if necessary.
+ */
+
+ Tcl_FreeParse(&synthetic);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileInfoExistsCmd --
+ *
+ * Procedure called to compile the "info exists" subcommand.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "info exists"
+ * subcommand at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileInfoExistsCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr;
+ int isScalar, simpleVarName, localIndex;
+ DefineLineInformation; /* TIP #280 */
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Decide if we can use a frame slot for the var/array name or if we need
+ * to emit code to compute and push the name at runtime. We use a frame
+ * slot (entry in the array of local vars) if we are compiling a procedure
+ * body and if the name is simple text that does not include namespace
+ * qualifiers.
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ PushVarNameWord(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex,
+ &simpleVarName, &isScalar, 1);
+
+ /*
+ * Emit instruction to check the variable for existence.
+ */
+
+ if (simpleVarName) {
+ if (isScalar) {
+ if (localIndex < 0) {
+ TclEmitOpcode(INST_EXIST_STK, envPtr);
+ } else {
+ TclEmitInstInt4(INST_EXIST_SCALAR, localIndex, envPtr);
+ }
+ } else {
+ if (localIndex < 0) {
+ TclEmitOpcode(INST_EXIST_ARRAY_STK, envPtr);
+ } else {
+ TclEmitInstInt4(INST_EXIST_ARRAY, localIndex, envPtr);
+ }
+ }
+ } else {
+ TclEmitOpcode(INST_EXIST_STK, envPtr);
+ }
+
+ return TCL_OK;
}
/*
@@ -3470,4 +6477,3 @@ TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr,
* fill-column: 78
* End:
*/
-