3612 lines
101 KiB
C
3612 lines
101 KiB
C
/*
|
||
* tclCompCmds.c --
|
||
*
|
||
* 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-2013 by Donal K. Fellows.
|
||
*
|
||
* See the file "license.terms" for information on usage and redistribution of
|
||
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||
*/
|
||
|
||
#include "tclInt.h"
|
||
#include "tclCompile.h"
|
||
#include <assert.h>
|
||
|
||
/*
|
||
* Prototypes for procedures defined later in this file:
|
||
*/
|
||
|
||
static ClientData DupDictUpdateInfo(ClientData clientData);
|
||
static void FreeDictUpdateInfo(ClientData clientData);
|
||
static void PrintDictUpdateInfo(ClientData clientData,
|
||
Tcl_Obj *appendObj, ByteCode *codePtr,
|
||
unsigned int pcOffset);
|
||
static void DisassembleDictUpdateInfo(ClientData clientData,
|
||
Tcl_Obj *dictObj, ByteCode *codePtr,
|
||
unsigned int pcOffset);
|
||
static ClientData DupForeachInfo(ClientData clientData);
|
||
static void FreeForeachInfo(ClientData clientData);
|
||
static void PrintForeachInfo(ClientData clientData,
|
||
Tcl_Obj *appendObj, ByteCode *codePtr,
|
||
unsigned int pcOffset);
|
||
static void DisassembleForeachInfo(ClientData clientData,
|
||
Tcl_Obj *dictObj, ByteCode *codePtr,
|
||
unsigned int pcOffset);
|
||
static void PrintNewForeachInfo(ClientData clientData,
|
||
Tcl_Obj *appendObj, ByteCode *codePtr,
|
||
unsigned int pcOffset);
|
||
static void DisassembleNewForeachInfo(ClientData clientData,
|
||
Tcl_Obj *dictObj, ByteCode *codePtr,
|
||
unsigned int pcOffset);
|
||
static int CompileEachloopCmd(Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr, Command *cmdPtr,
|
||
CompileEnv *envPtr, int collect);
|
||
static int CompileDictEachCmd(Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr, Command *cmdPtr,
|
||
struct CompileEnv *envPtr, int collect);
|
||
|
||
/*
|
||
* The structures below define the AuxData types defined in this file.
|
||
*/
|
||
|
||
static const AuxDataType foreachInfoType = {
|
||
"ForeachInfo", /* name */
|
||
DupForeachInfo, /* dupProc */
|
||
FreeForeachInfo, /* freeProc */
|
||
PrintForeachInfo, /* printProc */
|
||
DisassembleForeachInfo /* disassembleProc */
|
||
};
|
||
|
||
static const AuxDataType newForeachInfoType = {
|
||
"NewForeachInfo", /* name */
|
||
DupForeachInfo, /* dupProc */
|
||
FreeForeachInfo, /* freeProc */
|
||
PrintNewForeachInfo, /* printProc */
|
||
DisassembleNewForeachInfo /* disassembleProc */
|
||
};
|
||
|
||
static const AuxDataType dictUpdateInfoType = {
|
||
"DictUpdateInfo", /* name */
|
||
DupDictUpdateInfo, /* dupProc */
|
||
FreeDictUpdateInfo, /* freeProc */
|
||
PrintDictUpdateInfo, /* printProc */
|
||
DisassembleDictUpdateInfo /* disassembleProc */
|
||
};
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclGetAuxDataType --
|
||
*
|
||
* This procedure looks up an Auxdata type by name.
|
||
*
|
||
* Results:
|
||
* If an AuxData type with name matching "typeName" is found, a pointer
|
||
* to its AuxDataType structure is returned; otherwise, NULL is returned.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
const AuxDataType *
|
||
TclGetAuxDataType(
|
||
const char *typeName) /* Name of AuxData type to look up. */
|
||
{
|
||
if (!strcmp(typeName, foreachInfoType.name)) {
|
||
return &foreachInfoType;
|
||
} else if (!strcmp(typeName, newForeachInfoType.name)) {
|
||
return &newForeachInfoType;
|
||
} else if (!strcmp(typeName, dictUpdateInfoType.name)) {
|
||
return &dictUpdateInfoType;
|
||
} else if (!strcmp(typeName, tclJumptableInfoType.name)) {
|
||
return &tclJumptableInfoType;
|
||
}
|
||
return NULL;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileAppendCmd --
|
||
*
|
||
* Procedure called to compile the "append" 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 "append" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
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. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
Tcl_Token *varTokenPtr, *valueTokenPtr;
|
||
int isScalar, localIndex, numWords, i;
|
||
|
||
/* TODO: Consider support for compiling expanded args. */
|
||
numWords = parsePtr->numWords;
|
||
if (numWords == 1) {
|
||
return TCL_ERROR;
|
||
} else if (numWords == 2) {
|
||
/*
|
||
* append varName == set varName
|
||
*/
|
||
|
||
return TclCompileSetCmd(interp, parsePtr, cmdPtr, envPtr);
|
||
} else if (numWords > 3) {
|
||
/*
|
||
* APPEND instructions currently only handle one value, but we can
|
||
* handle some multi-value cases by stringing them together.
|
||
*/
|
||
|
||
goto appendMultiple;
|
||
}
|
||
|
||
/*
|
||
* Decide if we can use a frame slot for the var/array name or if we need
|
||
* to emit code to compute and push the name at runtime. We use a frame
|
||
* slot (entry in the array of local vars) if we are compiling a procedure
|
||
* body and if the name is simple text that does not include namespace
|
||
* qualifiers.
|
||
*/
|
||
|
||
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
|
||
PushVarNameWord(interp, varTokenPtr, envPtr, 0,
|
||
&localIndex, &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.
|
||
*/
|
||
|
||
valueTokenPtr = TokenAfter(varTokenPtr);
|
||
CompileWord(envPtr, valueTokenPtr, interp, 2);
|
||
|
||
/*
|
||
* Emit instructions to set/get the variable.
|
||
*/
|
||
|
||
if (isScalar) {
|
||
if (localIndex < 0) {
|
||
TclEmitOpcode(INST_APPEND_STK, envPtr);
|
||
} else {
|
||
Emit14Inst(INST_APPEND_SCALAR, localIndex, envPtr);
|
||
}
|
||
} else {
|
||
if (localIndex < 0) {
|
||
TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr);
|
||
} else {
|
||
Emit14Inst(INST_APPEND_ARRAY, localIndex, envPtr);
|
||
}
|
||
}
|
||
|
||
return TCL_OK;
|
||
|
||
appendMultiple:
|
||
/*
|
||
* Can only handle the case where we are appending to a local scalar when
|
||
* there are multiple values to append. Fortunately, this is common.
|
||
*/
|
||
|
||
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
|
||
localIndex = LocalScalarFromToken(varTokenPtr, envPtr);
|
||
if (localIndex < 0) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Definitely appending to a local scalar; generate the words and append
|
||
* them.
|
||
*/
|
||
|
||
valueTokenPtr = TokenAfter(varTokenPtr);
|
||
for (i = 2 ; i < numWords ; i++) {
|
||
CompileWord(envPtr, valueTokenPtr, interp, i);
|
||
valueTokenPtr = TokenAfter(valueTokenPtr);
|
||
}
|
||
TclEmitInstInt4( INST_REVERSE, numWords-2, envPtr);
|
||
for (i = 2 ; i < numWords ;) {
|
||
Emit14Inst( INST_APPEND_SCALAR, localIndex, envPtr);
|
||
if (++i < numWords) {
|
||
TclEmitOpcode(INST_POP, envPtr);
|
||
}
|
||
}
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileArray*Cmd --
|
||
*
|
||
* Functions called to compile "array" sucommands.
|
||
*
|
||
* Results:
|
||
* All return TCL_OK for a successful compile, and TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "array" subcommand at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileArrayExistsCmd(
|
||
Tcl_Interp *interp, /* Used for looking up stuff. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
Tcl_Token *tokenPtr;
|
||
int isScalar, localIndex;
|
||
|
||
if (parsePtr->numWords != 2) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT,
|
||
&localIndex, &isScalar, 1);
|
||
if (!isScalar) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (localIndex >= 0) {
|
||
TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
|
||
} else {
|
||
TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr);
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
int
|
||
TclCompileArraySetCmd(
|
||
Tcl_Interp *interp, /* Used for looking up stuff. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
Tcl_Token *varTokenPtr, *dataTokenPtr;
|
||
int isScalar, localIndex, code = TCL_OK;
|
||
int isDataLiteral, isDataValid, isDataEven, len;
|
||
int keyVar, valVar, infoIndex;
|
||
int fwd, offsetBack, offsetFwd;
|
||
Tcl_Obj *literalObj;
|
||
ForeachInfo *infoPtr;
|
||
|
||
if (parsePtr->numWords != 3) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
dataTokenPtr = TokenAfter(varTokenPtr);
|
||
literalObj = Tcl_NewObj();
|
||
isDataLiteral = TclWordKnownAtCompileTime(dataTokenPtr, literalObj);
|
||
isDataValid = (isDataLiteral
|
||
&& Tcl_ListObjLength(NULL, literalObj, &len) == TCL_OK);
|
||
isDataEven = (isDataValid && (len & 1) == 0);
|
||
|
||
/*
|
||
* Special case: literal odd-length argument is always an error.
|
||
*/
|
||
|
||
if (isDataValid && !isDataEven) {
|
||
/* Abandon custom compile and let invocation raise the error */
|
||
code = TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
|
||
goto done;
|
||
|
||
/*
|
||
* We used to compile to the bytecode that would throw the error,
|
||
* but that was wrong because it would not invoke the array trace
|
||
* on the variable.
|
||
*
|
||
PushStringLiteral(envPtr, "list must have an even number of elements");
|
||
PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}");
|
||
TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr);
|
||
TclEmitInt4( 0, envPtr);
|
||
goto done;
|
||
*
|
||
*/
|
||
}
|
||
|
||
/*
|
||
* Except for the special "ensure array" case below, when we're not in
|
||
* a proc, we cannot do a better compile than generic.
|
||
*/
|
||
|
||
if ((varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) ||
|
||
(envPtr->procPtr == NULL && !(isDataEven && len == 0))) {
|
||
code = TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
|
||
goto done;
|
||
}
|
||
|
||
PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT,
|
||
&localIndex, &isScalar, 1);
|
||
if (!isScalar) {
|
||
code = TCL_ERROR;
|
||
goto done;
|
||
}
|
||
|
||
/*
|
||
* Special case: literal empty value argument is just an "ensure array"
|
||
* operation.
|
||
*/
|
||
|
||
if (isDataEven && len == 0) {
|
||
if (localIndex >= 0) {
|
||
TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
|
||
TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr);
|
||
TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr);
|
||
} else {
|
||
TclEmitOpcode( INST_DUP, envPtr);
|
||
TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr);
|
||
TclEmitInstInt1(INST_JUMP_TRUE1, 5, envPtr);
|
||
TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr);
|
||
TclEmitInstInt1(INST_JUMP1, 3, envPtr);
|
||
/* Each branch decrements stack depth, but we only take one. */
|
||
TclAdjustStackDepth(1, envPtr);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
}
|
||
PushStringLiteral(envPtr, "");
|
||
goto done;
|
||
}
|
||
|
||
if (localIndex < 0) {
|
||
/*
|
||
* a non-local variable: upvar from a local one! This consumes the
|
||
* variable name that was left at stacktop.
|
||
*/
|
||
|
||
localIndex = TclFindCompiledLocal(varTokenPtr->start,
|
||
varTokenPtr->size, 1, envPtr);
|
||
PushStringLiteral(envPtr, "0");
|
||
TclEmitInstInt4(INST_REVERSE, 2, envPtr);
|
||
TclEmitInstInt4(INST_UPVAR, localIndex, envPtr);
|
||
TclEmitOpcode(INST_POP, envPtr);
|
||
}
|
||
|
||
/*
|
||
* Prepare for the internal foreach.
|
||
*/
|
||
|
||
keyVar = AnonymousLocal(envPtr);
|
||
valVar = AnonymousLocal(envPtr);
|
||
|
||
infoPtr = ckalloc(TclOffset(ForeachInfo, varLists) + sizeof(ForeachVarList *));
|
||
infoPtr->numLists = 1;
|
||
infoPtr->varLists[0] = ckalloc(TclOffset(ForeachVarList, varIndexes) + 2 * sizeof(int));
|
||
infoPtr->varLists[0]->numVars = 2;
|
||
infoPtr->varLists[0]->varIndexes[0] = keyVar;
|
||
infoPtr->varLists[0]->varIndexes[1] = valVar;
|
||
infoIndex = TclCreateAuxData(infoPtr, &newForeachInfoType, envPtr);
|
||
|
||
/*
|
||
* Start issuing instructions to write to the array.
|
||
*/
|
||
|
||
TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
|
||
TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr);
|
||
TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr);
|
||
|
||
CompileWord(envPtr, dataTokenPtr, interp, 2);
|
||
if (!isDataLiteral || !isDataValid) {
|
||
/*
|
||
* Only need this safety check if we're handling a non-literal or list
|
||
* containing an invalid literal; with valid list literals, we've
|
||
* already checked (worth it because literals are a very common
|
||
* use-case with [array set]).
|
||
*/
|
||
|
||
TclEmitOpcode( INST_DUP, envPtr);
|
||
TclEmitOpcode( INST_LIST_LENGTH, envPtr);
|
||
PushStringLiteral(envPtr, "1");
|
||
TclEmitOpcode( INST_BITAND, envPtr);
|
||
offsetFwd = CurrentOffset(envPtr);
|
||
TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
|
||
PushStringLiteral(envPtr, "list must have an even number of elements");
|
||
PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}");
|
||
TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr);
|
||
TclEmitInt4( 0, envPtr);
|
||
TclAdjustStackDepth(-1, envPtr);
|
||
fwd = CurrentOffset(envPtr) - offsetFwd;
|
||
TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
|
||
}
|
||
|
||
TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr);
|
||
offsetBack = CurrentOffset(envPtr);
|
||
Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr);
|
||
Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr);
|
||
Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
infoPtr->loopCtTemp = offsetBack - CurrentOffset(envPtr); /*misuse */
|
||
TclEmitOpcode( INST_FOREACH_STEP, envPtr);
|
||
TclEmitOpcode( INST_FOREACH_END, envPtr);
|
||
TclAdjustStackDepth(-3, envPtr);
|
||
PushStringLiteral(envPtr, "");
|
||
|
||
done:
|
||
Tcl_DecrRefCount(literalObj);
|
||
return code;
|
||
}
|
||
|
||
int
|
||
TclCompileArrayUnsetCmd(
|
||
Tcl_Interp *interp, /* Used for looking up stuff. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
int isScalar, localIndex;
|
||
|
||
if (parsePtr->numWords != 2) {
|
||
return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
|
||
}
|
||
|
||
PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT,
|
||
&localIndex, &isScalar, 1);
|
||
if (!isScalar) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (localIndex >= 0) {
|
||
TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
|
||
TclEmitInstInt1(INST_JUMP_FALSE1, 8, envPtr);
|
||
TclEmitInstInt1(INST_UNSET_SCALAR, 1, envPtr);
|
||
TclEmitInt4( localIndex, envPtr);
|
||
} else {
|
||
TclEmitOpcode( INST_DUP, envPtr);
|
||
TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr);
|
||
TclEmitInstInt1(INST_JUMP_FALSE1, 6, envPtr);
|
||
TclEmitInstInt1(INST_UNSET_STK, 1, envPtr);
|
||
TclEmitInstInt1(INST_JUMP1, 3, envPtr);
|
||
/* Each branch decrements stack depth, but we only take one. */
|
||
TclAdjustStackDepth(1, envPtr);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
}
|
||
PushStringLiteral(envPtr, "");
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileBreakCmd --
|
||
*
|
||
* Procedure called to compile the "break" 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 "break" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
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. */
|
||
{
|
||
ExceptionRange *rangePtr;
|
||
ExceptionAux *auxPtr;
|
||
|
||
if (parsePtr->numWords != 1) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Find the innermost exception range that contains this command.
|
||
*/
|
||
|
||
rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxPtr);
|
||
if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
|
||
/*
|
||
* Found the target! No need for a nasty INST_BREAK here.
|
||
*/
|
||
|
||
TclCleanupStackForBreakContinue(envPtr, auxPtr);
|
||
TclAddLoopBreakFixup(envPtr, auxPtr);
|
||
} else {
|
||
/*
|
||
* Emit a real break.
|
||
*/
|
||
|
||
TclEmitOpcode(INST_BREAK, envPtr);
|
||
}
|
||
TclAdjustStackDepth(1, envPtr);
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileCatchCmd --
|
||
*
|
||
* Procedure called to compile the "catch" 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 "catch" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
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. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
JumpFixup jumpFixup;
|
||
Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr;
|
||
int resultIndex, optsIndex, range, dropScript = 0;
|
||
int depth = TclGetStackDepth(envPtr);
|
||
|
||
/*
|
||
* If syntax does not match what we expect for [catch], do not compile.
|
||
* Let runtime checks determine if syntax has changed.
|
||
*/
|
||
|
||
if ((parsePtr->numWords < 2) || (parsePtr->numWords > 4)) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* If variables were specified and the catch command is at global level
|
||
* (not in a procedure), don't compile it inline: the payoff is too small.
|
||
*/
|
||
|
||
if ((parsePtr->numWords >= 3) && !EnvHasLVT(envPtr)) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Make sure the variable names, if any, have no substitutions and just
|
||
* refer to local scalars.
|
||
*/
|
||
|
||
resultIndex = optsIndex = -1;
|
||
cmdTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
if (parsePtr->numWords >= 3) {
|
||
resultNameTokenPtr = TokenAfter(cmdTokenPtr);
|
||
resultIndex = LocalScalarFromToken(resultNameTokenPtr, envPtr);
|
||
if (resultIndex < 0) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (parsePtr->numWords == 4) {
|
||
optsNameTokenPtr = TokenAfter(resultNameTokenPtr);
|
||
optsIndex = LocalScalarFromToken(optsNameTokenPtr, envPtr);
|
||
if (optsIndex < 0) {
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
}
|
||
|
||
/*
|
||
* We will compile the catch command. Declare the exception range that it
|
||
* uses.
|
||
*
|
||
* If the body is a simple word, compile a BEGIN_CATCH instruction,
|
||
* followed by the instructions to eval the body.
|
||
* Otherwise, compile instructions to substitute the body text before
|
||
* starting the catch, then BEGIN_CATCH, and then EVAL_STK to evaluate the
|
||
* substituted body.
|
||
* Care has to be taken to make sure that substitution happens outside the
|
||
* catch range so that errors in the substitution are not caught.
|
||
* [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.
|
||
*/
|
||
|
||
range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
|
||
if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
|
||
TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
|
||
ExceptionRangeStarts(envPtr, range);
|
||
BODY(cmdTokenPtr, 1);
|
||
} else {
|
||
SetLineInformation(1);
|
||
CompileTokens(envPtr, cmdTokenPtr, interp);
|
||
TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
|
||
ExceptionRangeStarts(envPtr, range);
|
||
TclEmitOpcode( INST_DUP, envPtr);
|
||
TclEmitInvoke(envPtr, INST_EVAL_STK);
|
||
/* drop the script */
|
||
dropScript = 1;
|
||
TclEmitInstInt4( INST_REVERSE, 2, envPtr);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
}
|
||
ExceptionRangeEnds(envPtr, range);
|
||
|
||
|
||
/*
|
||
* Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result,
|
||
* and jump around the "error case" code.
|
||
*/
|
||
|
||
TclCheckStackDepth(depth+1, envPtr);
|
||
PushStringLiteral(envPtr, "0");
|
||
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
|
||
|
||
/*
|
||
* Emit the "error case" epilogue. Push the interpreter result and the
|
||
* return code.
|
||
*/
|
||
|
||
ExceptionRangeTarget(envPtr, range, catchOffset);
|
||
TclSetStackDepth(depth + dropScript, envPtr);
|
||
|
||
if (dropScript) {
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
}
|
||
|
||
|
||
/* Stack at this point is empty */
|
||
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
|
||
TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr);
|
||
|
||
/* Stack at this point on both branches: result returnCode */
|
||
|
||
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
|
||
Tcl_Panic("TclCompileCatchCmd: bad jump distance %d",
|
||
(int)(CurrentOffset(envPtr) - jumpFixup.codeOffset));
|
||
}
|
||
|
||
/*
|
||
* Push the return options if the caller wants them. This needs to happen
|
||
* before INST_END_CATCH
|
||
*/
|
||
|
||
if (optsIndex != -1) {
|
||
TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
|
||
}
|
||
|
||
/*
|
||
* End the catch
|
||
*/
|
||
|
||
TclEmitOpcode( INST_END_CATCH, envPtr);
|
||
|
||
/*
|
||
* Save the result and return options if the caller wants them. This needs
|
||
* to happen after INST_END_CATCH (compile-3.6/7).
|
||
*/
|
||
|
||
if (optsIndex != -1) {
|
||
Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
}
|
||
|
||
/*
|
||
* At this point, the top of the stack is inconveniently ordered:
|
||
* result returnCode
|
||
* Reverse the stack to store the result.
|
||
*/
|
||
|
||
TclEmitInstInt4( INST_REVERSE, 2, envPtr);
|
||
if (resultIndex != -1) {
|
||
Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr);
|
||
}
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
|
||
TclCheckStackDepth(depth+1, envPtr);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileClockClicksCmd --
|
||
*
|
||
* Procedure called to compile the "tcl::clock::clicks" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to run time.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "clock clicks"
|
||
* command at runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileClockClicksCmd(
|
||
Tcl_Interp* interp, /* Tcl interpreter */
|
||
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;
|
||
|
||
switch (parsePtr->numWords) {
|
||
case 1:
|
||
/*
|
||
* No args
|
||
*/
|
||
TclEmitInstInt1(INST_CLOCK_READ, 0, envPtr);
|
||
break;
|
||
case 2:
|
||
/*
|
||
* -milliseconds or -microseconds
|
||
*/
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD
|
||
|| tokenPtr[1].size < 4
|
||
|| tokenPtr[1].size > 13) {
|
||
return TCL_ERROR;
|
||
} else if (!strncmp(tokenPtr[1].start, "-microseconds",
|
||
tokenPtr[1].size)) {
|
||
TclEmitInstInt1(INST_CLOCK_READ, 1, envPtr);
|
||
break;
|
||
} else if (!strncmp(tokenPtr[1].start, "-milliseconds",
|
||
tokenPtr[1].size)) {
|
||
TclEmitInstInt1(INST_CLOCK_READ, 2, envPtr);
|
||
break;
|
||
} else {
|
||
return TCL_ERROR;
|
||
}
|
||
default:
|
||
return TCL_ERROR;
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
|
||
/*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileClockReadingCmd --
|
||
*
|
||
* Procedure called to compile the "tcl::clock::microseconds",
|
||
* "tcl::clock::milliseconds" and "tcl::clock::seconds" commands.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to run time.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "clock clicks"
|
||
* command at runtime.
|
||
*
|
||
* Client data is 1 for microseconds, 2 for milliseconds, 3 for seconds.
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileClockReadingCmd(
|
||
Tcl_Interp* interp, /* Tcl interpreter */
|
||
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) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
TclEmitInstInt1(INST_CLOCK_READ, PTR2INT(cmdPtr->objClientData), envPtr);
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileConcatCmd --
|
||
*
|
||
* Procedure called to compile the "concat" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "concat" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileConcatCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
Tcl_Obj *objPtr, *listObj;
|
||
Tcl_Token *tokenPtr;
|
||
int i;
|
||
|
||
/* TODO: Consider compiling expansion case. */
|
||
if (parsePtr->numWords == 1) {
|
||
/*
|
||
* [concat] without arguments just pushes an empty object.
|
||
*/
|
||
|
||
PushStringLiteral(envPtr, "");
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* Test if all arguments are compile-time known. If they are, we can
|
||
* implement with a simple push.
|
||
*/
|
||
|
||
listObj = Tcl_NewObj();
|
||
for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) {
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
objPtr = Tcl_NewObj();
|
||
if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
|
||
Tcl_DecrRefCount(objPtr);
|
||
Tcl_DecrRefCount(listObj);
|
||
listObj = NULL;
|
||
break;
|
||
}
|
||
(void) Tcl_ListObjAppendElement(NULL, listObj, objPtr);
|
||
}
|
||
if (listObj != NULL) {
|
||
Tcl_Obj **objs;
|
||
const char *bytes;
|
||
int len;
|
||
|
||
Tcl_ListObjGetElements(NULL, listObj, &len, &objs);
|
||
objPtr = Tcl_ConcatObj(len, objs);
|
||
Tcl_DecrRefCount(listObj);
|
||
bytes = Tcl_GetStringFromObj(objPtr, &len);
|
||
PushLiteral(envPtr, bytes, len);
|
||
Tcl_DecrRefCount(objPtr);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* General case: runtime concat.
|
||
*/
|
||
|
||
for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) {
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, i);
|
||
}
|
||
|
||
TclEmitInstInt4( INST_CONCAT_STK, i-1, envPtr);
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileContinueCmd --
|
||
*
|
||
* Procedure called to compile the "continue" 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 "continue" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
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. */
|
||
{
|
||
ExceptionRange *rangePtr;
|
||
ExceptionAux *auxPtr;
|
||
|
||
/*
|
||
* There should be no argument after the "continue".
|
||
*/
|
||
|
||
if (parsePtr->numWords != 1) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* See if we can find a valid continueOffset (i.e., not -1) in the
|
||
* innermost containing exception range.
|
||
*/
|
||
|
||
rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, &auxPtr);
|
||
if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
|
||
/*
|
||
* Found the target! No need for a nasty INST_CONTINUE here.
|
||
*/
|
||
|
||
TclCleanupStackForBreakContinue(envPtr, auxPtr);
|
||
TclAddLoopContinueFixup(envPtr, auxPtr);
|
||
} else {
|
||
/*
|
||
* Emit a real continue.
|
||
*/
|
||
|
||
TclEmitOpcode(INST_CONTINUE, envPtr);
|
||
}
|
||
TclAdjustStackDepth(1, envPtr);
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
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. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
Tcl_Token *tokenPtr, *varTokenPtr;
|
||
int i, dictVarIndex;
|
||
|
||
/*
|
||
* There must be at least one argument after the command.
|
||
*/
|
||
|
||
if (parsePtr->numWords < 4) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* The dictionary variable must be a local scalar that is knowable at
|
||
* compile time; anything else exceeds the complexity of the opcode. So
|
||
* discover what the index is.
|
||
*/
|
||
|
||
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr);
|
||
if (dictVarIndex < 0) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Remaining words (key path and value to set) can be handled normally.
|
||
*/
|
||
|
||
tokenPtr = TokenAfter(varTokenPtr);
|
||
for (i=2 ; i< parsePtr->numWords ; i++) {
|
||
CompileWord(envPtr, tokenPtr, interp, i);
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
}
|
||
|
||
/*
|
||
* Now emit the instruction to do the dict manipulation.
|
||
*/
|
||
|
||
TclEmitInstInt4( INST_DICT_SET, parsePtr->numWords-3, envPtr);
|
||
TclEmitInt4( dictVarIndex, envPtr);
|
||
TclAdjustStackDepth(-1, 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. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
Tcl_Token *varTokenPtr, *keyTokenPtr;
|
||
int dictVarIndex, incrAmount;
|
||
|
||
/*
|
||
* There must be at least two arguments after the command.
|
||
*/
|
||
|
||
if (parsePtr->numWords < 3 || parsePtr->numWords > 4) {
|
||
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 TclCompileBasic2Or3ArgCmd(interp, parsePtr,cmdPtr, envPtr);
|
||
}
|
||
word = incrTokenPtr[1].start;
|
||
numBytes = incrTokenPtr[1].size;
|
||
|
||
intObj = Tcl_NewStringObj(word, numBytes);
|
||
Tcl_IncrRefCount(intObj);
|
||
code = TclGetIntFromObj(NULL, intObj, &incrAmount);
|
||
TclDecrRefCount(intObj);
|
||
if (code != TCL_OK) {
|
||
return TclCompileBasic2Or3ArgCmd(interp, parsePtr,cmdPtr, envPtr);
|
||
}
|
||
} else {
|
||
incrAmount = 1;
|
||
}
|
||
|
||
/*
|
||
* The dictionary variable must be a local scalar that is knowable at
|
||
* compile time; anything else exceeds the complexity of the opcode. So
|
||
* discover what the index is.
|
||
*/
|
||
|
||
dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr);
|
||
if (dictVarIndex < 0) {
|
||
return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
|
||
}
|
||
|
||
/*
|
||
* Emit the key and the code to actually do the increment.
|
||
*/
|
||
|
||
CompileWord(envPtr, keyTokenPtr, interp, 2);
|
||
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. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
Tcl_Token *tokenPtr;
|
||
int i;
|
||
|
||
/*
|
||
* There must be at least two arguments after the command (the single-arg
|
||
* case is legal, but too special and magic for us to deal with here).
|
||
*/
|
||
|
||
/* TODO: Consider support for compiling expanded args. */
|
||
if (parsePtr->numWords < 3) {
|
||
return TCL_ERROR;
|
||
}
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
|
||
/*
|
||
* Only compile this because we need INST_DICT_GET anyway.
|
||
*/
|
||
|
||
for (i=1 ; i<parsePtr->numWords ; i++) {
|
||
CompileWord(envPtr, tokenPtr, interp, i);
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
}
|
||
TclEmitInstInt4(INST_DICT_GET, parsePtr->numWords-2, envPtr);
|
||
TclAdjustStackDepth(-1, envPtr);
|
||
return TCL_OK;
|
||
}
|
||
|
||
int
|
||
TclCompileDictExistsCmd(
|
||
Tcl_Interp *interp, /* Used for looking up stuff. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
Tcl_Token *tokenPtr;
|
||
int i;
|
||
|
||
/*
|
||
* There must be at least two arguments after the command (the single-arg
|
||
* case is legal, but too special and magic for us to deal with here).
|
||
*/
|
||
|
||
/* TODO: Consider support for compiling expanded args. */
|
||
if (parsePtr->numWords < 3) {
|
||
return TCL_ERROR;
|
||
}
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
|
||
/*
|
||
* Now we do the code generation.
|
||
*/
|
||
|
||
for (i=1 ; i<parsePtr->numWords ; i++) {
|
||
CompileWord(envPtr, tokenPtr, interp, i);
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
}
|
||
TclEmitInstInt4(INST_DICT_EXISTS, parsePtr->numWords-2, envPtr);
|
||
TclAdjustStackDepth(-1, envPtr);
|
||
return TCL_OK;
|
||
}
|
||
|
||
int
|
||
TclCompileDictUnsetCmd(
|
||
Tcl_Interp *interp, /* Used for looking up stuff. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
Tcl_Token *tokenPtr;
|
||
int i, dictVarIndex;
|
||
|
||
/*
|
||
* There must be at least one argument after the variable name for us to
|
||
* compile to bytecode.
|
||
*/
|
||
|
||
/* TODO: Consider support for compiling expanded args. */
|
||
if (parsePtr->numWords < 3) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* The dictionary variable must be a local scalar that is knowable at
|
||
* compile time; anything else exceeds the complexity of the opcode. So
|
||
* discover what the index is.
|
||
*/
|
||
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr);
|
||
if (dictVarIndex < 0) {
|
||
return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
|
||
}
|
||
|
||
/*
|
||
* Remaining words (the key path) can be handled normally.
|
||
*/
|
||
|
||
for (i=2 ; i<parsePtr->numWords ; i++) {
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, i);
|
||
}
|
||
|
||
/*
|
||
* Now emit the instruction to do the dict manipulation.
|
||
*/
|
||
|
||
TclEmitInstInt4( INST_DICT_UNSET, parsePtr->numWords-2, envPtr);
|
||
TclEmitInt4( dictVarIndex, envPtr);
|
||
return TCL_OK;
|
||
}
|
||
|
||
int
|
||
TclCompileDictCreateCmd(
|
||
Tcl_Interp *interp, /* Used for looking up stuff. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
int worker; /* Temp var for building the value in. */
|
||
Tcl_Token *tokenPtr;
|
||
Tcl_Obj *keyObj, *valueObj, *dictObj;
|
||
const char *bytes;
|
||
int i, len;
|
||
|
||
if ((parsePtr->numWords & 1) == 0) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* See if we can build the value at compile time...
|
||
*/
|
||
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
dictObj = Tcl_NewObj();
|
||
Tcl_IncrRefCount(dictObj);
|
||
for (i=1 ; i<parsePtr->numWords ; i+=2) {
|
||
keyObj = Tcl_NewObj();
|
||
Tcl_IncrRefCount(keyObj);
|
||
if (!TclWordKnownAtCompileTime(tokenPtr, keyObj)) {
|
||
Tcl_DecrRefCount(keyObj);
|
||
Tcl_DecrRefCount(dictObj);
|
||
goto nonConstant;
|
||
}
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
valueObj = Tcl_NewObj();
|
||
Tcl_IncrRefCount(valueObj);
|
||
if (!TclWordKnownAtCompileTime(tokenPtr, valueObj)) {
|
||
Tcl_DecrRefCount(keyObj);
|
||
Tcl_DecrRefCount(valueObj);
|
||
Tcl_DecrRefCount(dictObj);
|
||
goto nonConstant;
|
||
}
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
Tcl_DictObjPut(NULL, dictObj, keyObj, valueObj);
|
||
Tcl_DecrRefCount(keyObj);
|
||
Tcl_DecrRefCount(valueObj);
|
||
}
|
||
|
||
/*
|
||
* We did! Excellent. The "verifyDict" is to do type forcing.
|
||
*/
|
||
|
||
bytes = Tcl_GetStringFromObj(dictObj, &len);
|
||
PushLiteral(envPtr, bytes, len);
|
||
TclEmitOpcode( INST_DUP, envPtr);
|
||
TclEmitOpcode( INST_DICT_VERIFY, envPtr);
|
||
Tcl_DecrRefCount(dictObj);
|
||
return TCL_OK;
|
||
|
||
/*
|
||
* Otherwise, we've got to issue runtime code to do the building, which we
|
||
* do by [dict set]ting into an unnamed local variable. This requires that
|
||
* we are in a context with an LVT.
|
||
*/
|
||
|
||
nonConstant:
|
||
worker = AnonymousLocal(envPtr);
|
||
if (worker < 0) {
|
||
return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
|
||
}
|
||
|
||
PushStringLiteral(envPtr, "");
|
||
Emit14Inst( INST_STORE_SCALAR, worker, envPtr);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
for (i=1 ; i<parsePtr->numWords ; i+=2) {
|
||
CompileWord(envPtr, tokenPtr, interp, i);
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, i+1);
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
TclEmitInstInt4( INST_DICT_SET, 1, envPtr);
|
||
TclEmitInt4( worker, envPtr);
|
||
TclAdjustStackDepth(-1, envPtr);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
}
|
||
Emit14Inst( INST_LOAD_SCALAR, worker, envPtr);
|
||
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
|
||
TclEmitInt4( worker, envPtr);
|
||
return TCL_OK;
|
||
}
|
||
|
||
int
|
||
TclCompileDictMergeCmd(
|
||
Tcl_Interp *interp, /* Used for looking up stuff. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
Tcl_Token *tokenPtr;
|
||
int i, workerIndex, infoIndex, outLoop;
|
||
|
||
/*
|
||
* Deal with some special edge cases. Note that in the case with one
|
||
* argument, the only thing to do is to verify the dict-ness.
|
||
*/
|
||
|
||
/* TODO: Consider support for compiling expanded args. (less likely) */
|
||
if (parsePtr->numWords < 2) {
|
||
PushStringLiteral(envPtr, "");
|
||
return TCL_OK;
|
||
} else if (parsePtr->numWords == 2) {
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, 1);
|
||
TclEmitOpcode( INST_DUP, envPtr);
|
||
TclEmitOpcode( INST_DICT_VERIFY, envPtr);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* There's real merging work to do.
|
||
*
|
||
* Allocate some working space. This means we'll only ever compile this
|
||
* command when there's an LVT present.
|
||
*/
|
||
|
||
workerIndex = AnonymousLocal(envPtr);
|
||
if (workerIndex < 0) {
|
||
return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
|
||
}
|
||
infoIndex = AnonymousLocal(envPtr);
|
||
|
||
/*
|
||
* Get the first dictionary and verify that it is so.
|
||
*/
|
||
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, 1);
|
||
TclEmitOpcode( INST_DUP, envPtr);
|
||
TclEmitOpcode( INST_DICT_VERIFY, envPtr);
|
||
Emit14Inst( INST_STORE_SCALAR, workerIndex, envPtr);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
|
||
/*
|
||
* For each of the remaining dictionaries...
|
||
*/
|
||
|
||
outLoop = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
|
||
TclEmitInstInt4( INST_BEGIN_CATCH4, outLoop, envPtr);
|
||
ExceptionRangeStarts(envPtr, outLoop);
|
||
for (i=2 ; i<parsePtr->numWords ; i++) {
|
||
/*
|
||
* Get the dictionary, and merge its pairs into the first dict (using
|
||
* a small loop).
|
||
*/
|
||
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, i);
|
||
TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr);
|
||
TclEmitInstInt1( INST_JUMP_TRUE1, 24, envPtr);
|
||
TclEmitInstInt4( INST_REVERSE, 2, envPtr);
|
||
TclEmitInstInt4( INST_DICT_SET, 1, envPtr);
|
||
TclEmitInt4( workerIndex, envPtr);
|
||
TclAdjustStackDepth(-1, envPtr);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr);
|
||
TclEmitInstInt1( INST_JUMP_FALSE1, -20, envPtr);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
|
||
TclEmitInt4( infoIndex, envPtr);
|
||
}
|
||
ExceptionRangeEnds(envPtr, outLoop);
|
||
TclEmitOpcode( INST_END_CATCH, envPtr);
|
||
|
||
/*
|
||
* Clean up any state left over.
|
||
*/
|
||
|
||
Emit14Inst( INST_LOAD_SCALAR, workerIndex, envPtr);
|
||
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
|
||
TclEmitInt4( workerIndex, envPtr);
|
||
TclEmitInstInt1( INST_JUMP1, 18, envPtr);
|
||
|
||
/*
|
||
* If an exception happens when starting to iterate over the second (and
|
||
* subsequent) dicts. This is strictly not necessary, but it is nice.
|
||
*/
|
||
|
||
TclAdjustStackDepth(-1, envPtr);
|
||
ExceptionRangeTarget(envPtr, outLoop, catchOffset);
|
||
TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
|
||
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
|
||
TclEmitOpcode( INST_END_CATCH, envPtr);
|
||
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
|
||
TclEmitInt4( workerIndex, envPtr);
|
||
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
|
||
TclEmitInt4( infoIndex, envPtr);
|
||
TclEmitOpcode( INST_RETURN_STK, envPtr);
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
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. */
|
||
{
|
||
return CompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr,
|
||
TCL_EACH_KEEP_NONE);
|
||
}
|
||
|
||
int
|
||
TclCompileDictMapCmd(
|
||
Tcl_Interp *interp, /* Used for looking up stuff. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
return CompileDictEachCmd(interp, parsePtr, cmdPtr, envPtr,
|
||
TCL_EACH_COLLECT);
|
||
}
|
||
|
||
int
|
||
CompileDictEachCmd(
|
||
Tcl_Interp *interp, /* Used for looking up stuff. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr, /* Holds resulting instructions. */
|
||
int collect) /* Flag == TCL_EACH_COLLECT to collect and
|
||
* construct a new dictionary with the loop
|
||
* body result. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr;
|
||
int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange;
|
||
int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset;
|
||
int numVars, endTargetOffset;
|
||
int collectVar = -1; /* Index of temp var holding the result
|
||
* dict. */
|
||
const char **argv;
|
||
Tcl_DString buffer;
|
||
|
||
/*
|
||
* There must be three arguments after the command.
|
||
*/
|
||
|
||
if (parsePtr->numWords != 4) {
|
||
return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
|
||
}
|
||
|
||
varsTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
dictTokenPtr = TokenAfter(varsTokenPtr);
|
||
bodyTokenPtr = TokenAfter(dictTokenPtr);
|
||
if (varsTokenPtr->type != TCL_TOKEN_SIMPLE_WORD ||
|
||
bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
|
||
return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
|
||
}
|
||
|
||
/*
|
||
* Create temporary variable to capture return values from loop body when
|
||
* we're collecting results.
|
||
*/
|
||
|
||
if (collect == TCL_EACH_COLLECT) {
|
||
collectVar = AnonymousLocal(envPtr);
|
||
if (collectVar < 0) {
|
||
return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Check we've got a pair of variables and that they are local variables.
|
||
* Then extract their indices in the LVT.
|
||
*/
|
||
|
||
Tcl_DStringInit(&buffer);
|
||
TclDStringAppendToken(&buffer, &varsTokenPtr[1]);
|
||
if (Tcl_SplitList(NULL, Tcl_DStringValue(&buffer), &numVars,
|
||
&argv) != TCL_OK) {
|
||
Tcl_DStringFree(&buffer);
|
||
return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
|
||
}
|
||
Tcl_DStringFree(&buffer);
|
||
if (numVars != 2) {
|
||
ckfree(argv);
|
||
return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
|
||
}
|
||
|
||
nameChars = strlen(argv[0]);
|
||
keyVarIndex = LocalScalar(argv[0], nameChars, envPtr);
|
||
nameChars = strlen(argv[1]);
|
||
valueVarIndex = LocalScalar(argv[1], nameChars, envPtr);
|
||
ckfree(argv);
|
||
|
||
if ((keyVarIndex < 0) || (valueVarIndex < 0)) {
|
||
return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
|
||
}
|
||
|
||
/*
|
||
* 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 = AnonymousLocal(envPtr);
|
||
if (infoIndex < 0) {
|
||
return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
|
||
}
|
||
|
||
/*
|
||
* Preparation complete; issue instructions. Note that this code issues
|
||
* fixed-sized jumps. That simplifies things a lot!
|
||
*
|
||
* First up, initialize the accumulator dictionary if needed.
|
||
*/
|
||
|
||
if (collect == TCL_EACH_COLLECT) {
|
||
PushStringLiteral(envPtr, "");
|
||
Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
}
|
||
|
||
/*
|
||
* Get the dictionary and start the iteration. No catching of errors at
|
||
* this point.
|
||
*/
|
||
|
||
CompileWord(envPtr, dictTokenPtr, interp, 2);
|
||
|
||
/*
|
||
* Now we catch errors from here on so that we can finalize the search
|
||
* started by Tcl_DictObjFirst above.
|
||
*/
|
||
|
||
catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
|
||
TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr);
|
||
ExceptionRangeStarts(envPtr, catchRange);
|
||
|
||
TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr);
|
||
emptyTargetOffset = CurrentOffset(envPtr);
|
||
TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr);
|
||
|
||
/*
|
||
* Inside the iteration, write the loop variables.
|
||
*/
|
||
|
||
bodyTargetOffset = CurrentOffset(envPtr);
|
||
Emit14Inst( INST_STORE_SCALAR, keyVarIndex, envPtr);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
Emit14Inst( INST_STORE_SCALAR, valueVarIndex, envPtr);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
|
||
/*
|
||
* Set up the loop exception targets.
|
||
*/
|
||
|
||
loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
|
||
ExceptionRangeStarts(envPtr, loopRange);
|
||
|
||
/*
|
||
* Compile the loop body itself. It should be stack-neutral.
|
||
*/
|
||
|
||
BODY(bodyTokenPtr, 3);
|
||
if (collect == TCL_EACH_COLLECT) {
|
||
Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr);
|
||
TclEmitInstInt4(INST_OVER, 1, envPtr);
|
||
TclEmitInstInt4(INST_DICT_SET, 1, envPtr);
|
||
TclEmitInt4( collectVar, envPtr);
|
||
TclAdjustStackDepth(-1, envPtr);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
}
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
|
||
/*
|
||
* Both exception target ranges (error and loop) end here.
|
||
*/
|
||
|
||
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);
|
||
endTargetOffset = CurrentOffset(envPtr);
|
||
TclEmitInstInt1( INST_JUMP1, 0, envPtr);
|
||
|
||
/*
|
||
* Error handler "finally" clause, which force-terminates the iteration
|
||
* and rethrows the error.
|
||
*/
|
||
|
||
TclAdjustStackDepth(-1, envPtr);
|
||
ExceptionRangeTarget(envPtr, catchRange, catchOffset);
|
||
TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
|
||
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
|
||
TclEmitOpcode( INST_END_CATCH, envPtr);
|
||
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
|
||
TclEmitInt4( infoIndex, envPtr);
|
||
if (collect == TCL_EACH_COLLECT) {
|
||
TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr);
|
||
TclEmitInt4( collectVar, envPtr);
|
||
}
|
||
TclEmitOpcode( INST_RETURN_STK, envPtr);
|
||
|
||
/*
|
||
* Otherwise we're done (the jump after the DICT_FIRST points here) and we
|
||
* need to pop the bogus key/value pair (pushed to keep stack calculations
|
||
* easy!) Note that we skip the END_CATCH. [Bug 1382528]
|
||
*/
|
||
|
||
jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset;
|
||
TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement,
|
||
envPtr->codeStart + emptyTargetOffset);
|
||
jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset;
|
||
TclUpdateInstInt1AtPc(INST_JUMP1, jumpDisplacement,
|
||
envPtr->codeStart + endTargetOffset);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
ExceptionRangeTarget(envPtr, loopRange, breakOffset);
|
||
TclFinalizeLoopExceptionRange(envPtr, loopRange);
|
||
TclEmitOpcode( INST_END_CATCH, envPtr);
|
||
|
||
/*
|
||
* Final stage of the command (normal case) is that we push an empty
|
||
* object (or push the accumulator as the result object). This is done
|
||
* last to promote peephole optimization when it's dropped immediately.
|
||
*/
|
||
|
||
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
|
||
TclEmitInt4( infoIndex, envPtr);
|
||
if (collect == TCL_EACH_COLLECT) {
|
||
Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr);
|
||
TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr);
|
||
TclEmitInt4( collectVar, envPtr);
|
||
} else {
|
||
PushStringLiteral(envPtr, "");
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
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. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
int i, 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) {
|
||
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);
|
||
dictIndex = LocalScalarFromToken(dictVarTokenPtr, envPtr);
|
||
if (dictIndex < 0) {
|
||
goto issueFallback;
|
||
}
|
||
|
||
/*
|
||
* 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 = ckalloc(TclOffset(DictUpdateInfo, varIndices) + sizeof(int) * numVars);
|
||
duiPtr->length = numVars;
|
||
keyTokenPtrs = 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;
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
|
||
/*
|
||
* Stash the index in the auxiliary data (if it is indeed a local
|
||
* scalar that is resolvable at compile-time).
|
||
*/
|
||
|
||
duiPtr->varIndices[i] = LocalScalarFromToken(tokenPtr, envPtr);
|
||
if (duiPtr->varIndices[i] < 0) {
|
||
goto failedUpdateInfoAssembly;
|
||
}
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
}
|
||
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
|
||
goto failedUpdateInfoAssembly;
|
||
}
|
||
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, &dictUpdateInfoType, envPtr);
|
||
|
||
for (i=0 ; i<numVars ; i++) {
|
||
CompileWord(envPtr, keyTokenPtrs[i], interp, 2*i+2);
|
||
}
|
||
TclEmitInstInt4( INST_LIST, numVars, envPtr);
|
||
TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr);
|
||
TclEmitInt4( infoIndex, envPtr);
|
||
|
||
range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
|
||
TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
|
||
|
||
ExceptionRangeStarts(envPtr, range);
|
||
BODY(bodyTokenPtr, parsePtr->numWords - 1);
|
||
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);
|
||
TclEmitInvoke(envPtr,INST_RETURN_STK);
|
||
|
||
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
|
||
Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
|
||
(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
|
||
}
|
||
TclStackFree(interp, keyTokenPtrs);
|
||
return TCL_OK;
|
||
|
||
/*
|
||
* Clean up after a failure to create the DictUpdateInfo structure.
|
||
*/
|
||
|
||
failedUpdateInfoAssembly:
|
||
ckfree(duiPtr);
|
||
TclStackFree(interp, keyTokenPtrs);
|
||
issueFallback:
|
||
return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
|
||
}
|
||
|
||
int
|
||
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. */
|
||
{
|
||
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. ;-)
|
||
*/
|
||
|
||
/* TODO: Consider support for compiling expanded args. */
|
||
if (parsePtr->numWords<4 || parsePtr->numWords>100) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Get the index of the local variable that we will be working with.
|
||
*/
|
||
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr);
|
||
if (dictVarIndex < 0) {
|
||
return TclCompileBasicMin2ArgCmd(interp, parsePtr,cmdPtr, envPtr);
|
||
}
|
||
|
||
/*
|
||
* 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_STR_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. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
Tcl_Token *varTokenPtr, *keyTokenPtr, *valueTokenPtr;
|
||
int dictVarIndex;
|
||
|
||
/*
|
||
* There must be three arguments after the command.
|
||
*/
|
||
|
||
/* TODO: Consider support for compiling expanded args. */
|
||
/* Probably not. Why is INST_DICT_LAPPEND limited to one value? */
|
||
if (parsePtr->numWords != 4) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Parse the arguments.
|
||
*/
|
||
|
||
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
keyTokenPtr = TokenAfter(varTokenPtr);
|
||
valueTokenPtr = TokenAfter(keyTokenPtr);
|
||
dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr);
|
||
if (dictVarIndex < 0) {
|
||
return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
|
||
}
|
||
|
||
/*
|
||
* Issue the implementation.
|
||
*/
|
||
|
||
CompileWord(envPtr, keyTokenPtr, interp, 2);
|
||
CompileWord(envPtr, valueTokenPtr, interp, 3);
|
||
TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr);
|
||
return TCL_OK;
|
||
}
|
||
|
||
int
|
||
TclCompileDictWithCmd(
|
||
Tcl_Interp *interp, /* Used for looking up stuff. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
int i, range, varNameTmp = -1, pathTmp = -1, keysTmp, gotPath;
|
||
int dictVar, bodyIsEmpty = 1;
|
||
Tcl_Token *varTokenPtr, *tokenPtr;
|
||
JumpFixup jumpFixup;
|
||
const char *ptr, *end;
|
||
|
||
/*
|
||
* There must be at least one argument after the command.
|
||
*/
|
||
|
||
/* TODO: Consider support for compiling expanded args. */
|
||
if (parsePtr->numWords < 3) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Parse the command (trivially). Expect the following:
|
||
* dict with <any (varName)> ?<any> ...? <literal>
|
||
*/
|
||
|
||
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
tokenPtr = TokenAfter(varTokenPtr);
|
||
for (i=3 ; i<parsePtr->numWords ; i++) {
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
}
|
||
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
|
||
return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
|
||
}
|
||
|
||
/*
|
||
* Test if the last word is an empty script; if so, we can compile it in
|
||
* all cases, but if it is non-empty we need local variable table entries
|
||
* to hold the temporary variables (used to keep stack usage simple).
|
||
*/
|
||
|
||
for (ptr=tokenPtr[1].start,end=ptr+tokenPtr[1].size ; ptr!=end ; ptr++) {
|
||
if (*ptr!=' ' && *ptr!='\t' && *ptr!='\n' && *ptr!='\r') {
|
||
if (envPtr->procPtr == NULL) {
|
||
return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr,
|
||
envPtr);
|
||
}
|
||
bodyIsEmpty = 0;
|
||
break;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Determine if we're manipulating a dict in a simple local variable.
|
||
*/
|
||
|
||
gotPath = (parsePtr->numWords > 3);
|
||
dictVar = LocalScalarFromToken(varTokenPtr, envPtr);
|
||
|
||
/*
|
||
* Special case: an empty body means we definitely have no need to issue
|
||
* try-finally style code or to allocate local variable table entries for
|
||
* storing temporaries. Still need to do both INST_DICT_EXPAND and
|
||
* INST_DICT_RECOMBINE_* though, because we can't determine if we're free
|
||
* of traces.
|
||
*/
|
||
|
||
if (bodyIsEmpty) {
|
||
if (dictVar >= 0) {
|
||
if (gotPath) {
|
||
/*
|
||
* Case: Path into dict in LVT with empty body.
|
||
*/
|
||
|
||
tokenPtr = TokenAfter(varTokenPtr);
|
||
for (i=2 ; i<parsePtr->numWords-1 ; i++) {
|
||
CompileWord(envPtr, tokenPtr, interp, i);
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
}
|
||
TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr);
|
||
Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr);
|
||
TclEmitInstInt4(INST_OVER, 1, envPtr);
|
||
TclEmitOpcode( INST_DICT_EXPAND, envPtr);
|
||
TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
|
||
} else {
|
||
/*
|
||
* Case: Direct dict in LVT with empty body.
|
||
*/
|
||
|
||
PushStringLiteral(envPtr, "");
|
||
Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr);
|
||
PushStringLiteral(envPtr, "");
|
||
TclEmitOpcode( INST_DICT_EXPAND, envPtr);
|
||
TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
|
||
}
|
||
} else {
|
||
if (gotPath) {
|
||
/*
|
||
* Case: Path into dict in non-simple var with empty body.
|
||
*/
|
||
|
||
tokenPtr = varTokenPtr;
|
||
for (i=1 ; i<parsePtr->numWords-1 ; i++) {
|
||
CompileWord(envPtr, tokenPtr, interp, i);
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
}
|
||
TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr);
|
||
TclEmitInstInt4(INST_OVER, 1, envPtr);
|
||
TclEmitOpcode( INST_LOAD_STK, envPtr);
|
||
TclEmitInstInt4(INST_OVER, 1, envPtr);
|
||
TclEmitOpcode( INST_DICT_EXPAND, envPtr);
|
||
TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr);
|
||
} else {
|
||
/*
|
||
* Case: Direct dict in non-simple var with empty body.
|
||
*/
|
||
|
||
CompileWord(envPtr, varTokenPtr, interp, 1);
|
||
TclEmitOpcode( INST_DUP, envPtr);
|
||
TclEmitOpcode( INST_LOAD_STK, envPtr);
|
||
PushStringLiteral(envPtr, "");
|
||
TclEmitOpcode( INST_DICT_EXPAND, envPtr);
|
||
PushStringLiteral(envPtr, "");
|
||
TclEmitInstInt4(INST_REVERSE, 2, envPtr);
|
||
TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr);
|
||
}
|
||
}
|
||
PushStringLiteral(envPtr, "");
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* OK, we have a non-trivial body. This means that the focus is on
|
||
* generating a try-finally structure where the INST_DICT_RECOMBINE_* goes
|
||
* in the 'finally' clause.
|
||
*
|
||
* Start by allocating local (unnamed, untraced) working variables.
|
||
*/
|
||
|
||
if (dictVar == -1) {
|
||
varNameTmp = AnonymousLocal(envPtr);
|
||
}
|
||
if (gotPath) {
|
||
pathTmp = AnonymousLocal(envPtr);
|
||
}
|
||
keysTmp = AnonymousLocal(envPtr);
|
||
|
||
/*
|
||
* Issue instructions. First, the part to expand the dictionary.
|
||
*/
|
||
|
||
if (dictVar == -1) {
|
||
CompileWord(envPtr, varTokenPtr, interp, 1);
|
||
Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr);
|
||
}
|
||
tokenPtr = TokenAfter(varTokenPtr);
|
||
if (gotPath) {
|
||
for (i=2 ; i<parsePtr->numWords-1 ; i++) {
|
||
CompileWord(envPtr, tokenPtr, interp, i);
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
}
|
||
TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr);
|
||
Emit14Inst( INST_STORE_SCALAR, pathTmp, envPtr);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
}
|
||
if (dictVar == -1) {
|
||
TclEmitOpcode( INST_LOAD_STK, envPtr);
|
||
} else {
|
||
Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr);
|
||
}
|
||
if (gotPath) {
|
||
Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr);
|
||
} else {
|
||
PushStringLiteral(envPtr, "");
|
||
}
|
||
TclEmitOpcode( INST_DICT_EXPAND, envPtr);
|
||
Emit14Inst( INST_STORE_SCALAR, keysTmp, envPtr);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
|
||
/*
|
||
* Now the body of the [dict with].
|
||
*/
|
||
|
||
range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
|
||
TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
|
||
|
||
ExceptionRangeStarts(envPtr, range);
|
||
BODY(tokenPtr, parsePtr->numWords - 1);
|
||
ExceptionRangeEnds(envPtr, range);
|
||
|
||
/*
|
||
* Now fold the results back into the dictionary in the OK case.
|
||
*/
|
||
|
||
TclEmitOpcode( INST_END_CATCH, envPtr);
|
||
if (dictVar == -1) {
|
||
Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr);
|
||
}
|
||
if (gotPath) {
|
||
Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr);
|
||
} else {
|
||
PushStringLiteral(envPtr, "");
|
||
}
|
||
Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr);
|
||
if (dictVar == -1) {
|
||
TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr);
|
||
} else {
|
||
TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
|
||
}
|
||
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
|
||
|
||
/*
|
||
* Now fold the results back into the dictionary in the exception case.
|
||
*/
|
||
|
||
TclAdjustStackDepth(-1, envPtr);
|
||
ExceptionRangeTarget(envPtr, range, catchOffset);
|
||
TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
|
||
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
|
||
TclEmitOpcode( INST_END_CATCH, envPtr);
|
||
if (dictVar == -1) {
|
||
Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr);
|
||
}
|
||
if (parsePtr->numWords > 3) {
|
||
Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr);
|
||
} else {
|
||
PushStringLiteral(envPtr, "");
|
||
}
|
||
Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr);
|
||
if (dictVar == -1) {
|
||
TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr);
|
||
} else {
|
||
TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
|
||
}
|
||
TclEmitInvoke(envPtr, INST_RETURN_STK);
|
||
|
||
/*
|
||
* Prepare for the start of the next command.
|
||
*/
|
||
|
||
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
|
||
Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
|
||
(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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
|
||
* DisassembleDictUpdateInfo: none
|
||
*
|
||
* Side effects:
|
||
* DupDictUpdateInfo: allocates memory
|
||
* FreeDictUpdateInfo: releases memory
|
||
* PrintDictUpdateInfo: none
|
||
* DisassembleDictUpdateInfo: none
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static ClientData
|
||
DupDictUpdateInfo(
|
||
ClientData clientData)
|
||
{
|
||
DictUpdateInfo *dui1Ptr, *dui2Ptr;
|
||
unsigned len;
|
||
|
||
dui1Ptr = clientData;
|
||
len = TclOffset(DictUpdateInfo, varIndices) + sizeof(int) * dui1Ptr->length;
|
||
dui2Ptr = 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]);
|
||
}
|
||
}
|
||
|
||
static void
|
||
DisassembleDictUpdateInfo(
|
||
ClientData clientData,
|
||
Tcl_Obj *dictObj,
|
||
ByteCode *codePtr,
|
||
unsigned int pcOffset)
|
||
{
|
||
DictUpdateInfo *duiPtr = clientData;
|
||
int i;
|
||
Tcl_Obj *variables = Tcl_NewObj();
|
||
|
||
for (i=0 ; i<duiPtr->length ; i++) {
|
||
Tcl_ListObjAppendElement(NULL, variables,
|
||
Tcl_NewIntObj(duiPtr->varIndices[i]));
|
||
}
|
||
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("variables", -1),
|
||
variables);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileErrorCmd --
|
||
*
|
||
* Procedure called to compile the "error" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "error" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileErrorCmd(
|
||
Tcl_Interp *interp, /* Used for context. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
Tcl_Token *tokenPtr;
|
||
|
||
/*
|
||
* General syntax: [error message ?errorInfo? ?errorCode?]
|
||
*/
|
||
|
||
if (parsePtr->numWords < 2 || parsePtr->numWords > 4) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Handle the message.
|
||
*/
|
||
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, 1);
|
||
|
||
/*
|
||
* Construct the options. Note that -code and -level are not here.
|
||
*/
|
||
|
||
if (parsePtr->numWords == 2) {
|
||
PushStringLiteral(envPtr, "");
|
||
} else {
|
||
PushStringLiteral(envPtr, "-errorinfo");
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, 2);
|
||
if (parsePtr->numWords == 3) {
|
||
TclEmitInstInt4( INST_LIST, 2, envPtr);
|
||
} else {
|
||
PushStringLiteral(envPtr, "-errorcode");
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, 3);
|
||
TclEmitInstInt4( INST_LIST, 4, envPtr);
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Issue the error via 'returnImm error 0'.
|
||
*/
|
||
|
||
TclEmitInstInt4( INST_RETURN_IMM, TCL_ERROR, envPtr);
|
||
TclEmitInt4( 0, envPtr);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileExprCmd --
|
||
*
|
||
* Procedure called to compile the "expr" 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 "expr" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
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;
|
||
|
||
if (parsePtr->numWords == 1) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* 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;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileForCmd --
|
||
*
|
||
* Procedure called to compile the "for" 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 "for" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
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. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;
|
||
JumpFixup jumpEvalCondFixup;
|
||
int bodyCodeOffset, nextCodeOffset, jumpDist;
|
||
int bodyRange, nextRange;
|
||
|
||
if (parsePtr->numWords != 5) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* If the test expression requires substitutions, don't compile the for
|
||
* command inline. E.g., the expression might cause the loop to never
|
||
* execute or execute forever, as in "for {} "$x > 5" {incr x} {}".
|
||
*/
|
||
|
||
startTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
testTokenPtr = TokenAfter(startTokenPtr);
|
||
if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Bail out also if the body or the next expression require substitutions
|
||
* in order to insure correct behaviour [Bug 219166]
|
||
*/
|
||
|
||
nextTokenPtr = TokenAfter(testTokenPtr);
|
||
bodyTokenPtr = TokenAfter(nextTokenPtr);
|
||
if ((nextTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
|
||
|| (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Inline compile the initial command.
|
||
*/
|
||
|
||
BODY(startTokenPtr, 1);
|
||
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).
|
||
* "for start cond next body" produces then:
|
||
* start
|
||
* goto A
|
||
* B: body : bodyCodeOffset
|
||
* next : nextCodeOffset, continueOffset
|
||
* A: cond -> result : testCodeOffset
|
||
* if (result) goto B
|
||
*/
|
||
|
||
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);
|
||
|
||
/*
|
||
* Compile the loop body.
|
||
*/
|
||
|
||
bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
|
||
bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange);
|
||
BODY(bodyTokenPtr, 4);
|
||
ExceptionRangeEnds(envPtr, bodyRange);
|
||
TclEmitOpcode(INST_POP, envPtr);
|
||
|
||
/*
|
||
* Compile the "next" subcommand. Note that this exception range will not
|
||
* have a continueOffset (other than -1) connected to it; it won't trap
|
||
* TCL_CONTINUE but rather just TCL_BREAK.
|
||
*/
|
||
|
||
nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
|
||
envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0;
|
||
nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange);
|
||
BODY(nextTokenPtr, 3);
|
||
ExceptionRangeEnds(envPtr, nextRange);
|
||
TclEmitOpcode(INST_POP, envPtr);
|
||
|
||
/*
|
||
* Compile the test expression then emit the conditional jump that
|
||
* terminates the for.
|
||
*/
|
||
|
||
if (TclFixupForwardJumpToHere(envPtr, &jumpEvalCondFixup, 127)) {
|
||
bodyCodeOffset += 3;
|
||
nextCodeOffset += 3;
|
||
}
|
||
|
||
SetLineInformation(2);
|
||
TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
|
||
|
||
jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
|
||
if (jumpDist > 127) {
|
||
TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
|
||
} else {
|
||
TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
|
||
}
|
||
|
||
/*
|
||
* 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;
|
||
envPtr->exceptArrayPtr[bodyRange].continueOffset = nextCodeOffset;
|
||
|
||
envPtr->exceptArrayPtr[nextRange].codeOffset = nextCodeOffset;
|
||
|
||
ExceptionRangeTarget(envPtr, bodyRange, breakOffset);
|
||
ExceptionRangeTarget(envPtr, nextRange, breakOffset);
|
||
TclFinalizeLoopExceptionRange(envPtr, bodyRange);
|
||
TclFinalizeLoopExceptionRange(envPtr, nextRange);
|
||
|
||
/*
|
||
* The for command's result is an empty string.
|
||
*/
|
||
|
||
PushStringLiteral(envPtr, "");
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileForeachCmd --
|
||
*
|
||
* Procedure called to compile the "foreach" 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 "foreach" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
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. */
|
||
{
|
||
return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr,
|
||
TCL_EACH_KEEP_NONE);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileLmapCmd --
|
||
*
|
||
* Procedure called to compile the "lmap" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "lmap" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileLmapCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr,
|
||
TCL_EACH_COLLECT);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* CompileEachloopCmd --
|
||
*
|
||
* Procedure called to compile the "foreach" and "lmap" commands.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "foreach" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
CompileEachloopCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr, /* Holds resulting instructions. */
|
||
int collect) /* Select collecting or accumulating mode
|
||
* (TCL_EACH_*) */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
Proc *procPtr = envPtr->procPtr;
|
||
ForeachInfo *infoPtr=NULL; /* Points to the structure describing this
|
||
* foreach command. Stored in a AuxData
|
||
* record in the ByteCode. */
|
||
|
||
Tcl_Token *tokenPtr, *bodyTokenPtr;
|
||
int jumpBackOffset, infoIndex, range;
|
||
int numWords, numLists, i, j, code = TCL_OK;
|
||
Tcl_Obj *varListObj = NULL;
|
||
|
||
/*
|
||
* If the foreach command isn't in a procedure, don't compile it inline:
|
||
* the payoff is too small.
|
||
*/
|
||
|
||
if (procPtr == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
numWords = parsePtr->numWords;
|
||
if ((numWords < 4) || (numWords%2 != 0)) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* 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 = TokenAfter(tokenPtr);
|
||
}
|
||
bodyTokenPtr = tokenPtr;
|
||
if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Create and initialize the ForeachInfo and ForeachVarList data
|
||
* structures describing this command. Then create a AuxData record
|
||
* pointing to the ForeachInfo structure.
|
||
*/
|
||
|
||
numLists = (numWords - 2)/2;
|
||
infoPtr = ckalloc(TclOffset(ForeachInfo, varLists)
|
||
+ numLists * sizeof(ForeachVarList *));
|
||
infoPtr->numLists = 0; /* Count this up as we go */
|
||
|
||
/*
|
||
* Parse each var list into sequence of var names. Don't
|
||
* compile the foreach inline if any var name needs substitutions or isn't
|
||
* a scalar, or if any var list needs substitutions.
|
||
*/
|
||
|
||
varListObj = Tcl_NewObj();
|
||
for (i = 0, tokenPtr = parsePtr->tokenPtr;
|
||
i < numWords-1;
|
||
i++, tokenPtr = TokenAfter(tokenPtr)) {
|
||
ForeachVarList *varListPtr;
|
||
int numVars;
|
||
|
||
if (i%2 != 1) {
|
||
continue;
|
||
}
|
||
|
||
/*
|
||
* 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 (!TclWordKnownAtCompileTime(tokenPtr, varListObj) ||
|
||
TCL_OK != Tcl_ListObjLength(NULL, varListObj, &numVars) ||
|
||
numVars == 0) {
|
||
code = TCL_ERROR;
|
||
goto done;
|
||
}
|
||
|
||
varListPtr = ckalloc(TclOffset(ForeachVarList, varIndexes)
|
||
+ numVars * sizeof(int));
|
||
varListPtr->numVars = numVars;
|
||
infoPtr->varLists[i/2] = varListPtr;
|
||
infoPtr->numLists++;
|
||
|
||
for (j = 0; j < numVars; j++) {
|
||
Tcl_Obj *varNameObj;
|
||
const char *bytes;
|
||
int numBytes, varIndex;
|
||
|
||
Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj);
|
||
bytes = Tcl_GetStringFromObj(varNameObj, &numBytes);
|
||
varIndex = LocalScalar(bytes, numBytes, envPtr);
|
||
if (varIndex < 0) {
|
||
code = TCL_ERROR;
|
||
goto done;
|
||
}
|
||
varListPtr->varIndexes[j] = varIndex;
|
||
}
|
||
Tcl_SetObjLength(varListObj, 0);
|
||
}
|
||
|
||
/*
|
||
* We will compile the foreach command.
|
||
*/
|
||
|
||
infoIndex = TclCreateAuxData(infoPtr, &newForeachInfoType, envPtr);
|
||
|
||
/*
|
||
* Create the collecting object, unshared.
|
||
*/
|
||
|
||
if (collect == TCL_EACH_COLLECT) {
|
||
TclEmitInstInt4(INST_LIST, 0, envPtr);
|
||
}
|
||
|
||
/*
|
||
* Evaluate each value list and leave it on stack.
|
||
*/
|
||
|
||
for (i = 0, tokenPtr = parsePtr->tokenPtr;
|
||
i < numWords-1;
|
||
i++, tokenPtr = TokenAfter(tokenPtr)) {
|
||
if ((i%2 == 0) && (i > 0)) {
|
||
CompileWord(envPtr, tokenPtr, interp, i);
|
||
}
|
||
}
|
||
|
||
TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr);
|
||
|
||
/*
|
||
* Inline compile the loop body.
|
||
*/
|
||
|
||
range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
|
||
|
||
ExceptionRangeStarts(envPtr, range);
|
||
BODY(bodyTokenPtr, numWords - 1);
|
||
ExceptionRangeEnds(envPtr, range);
|
||
|
||
if (collect == TCL_EACH_COLLECT) {
|
||
TclEmitOpcode(INST_LMAP_COLLECT, envPtr);
|
||
} else {
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
}
|
||
|
||
/*
|
||
* Bottom of loop code: assign each loop variable and check whether
|
||
* to terminate the loop. Set the loop's break target.
|
||
*/
|
||
|
||
ExceptionRangeTarget(envPtr, range, continueOffset);
|
||
TclEmitOpcode(INST_FOREACH_STEP, envPtr);
|
||
ExceptionRangeTarget(envPtr, range, breakOffset);
|
||
TclFinalizeLoopExceptionRange(envPtr, range);
|
||
TclEmitOpcode(INST_FOREACH_END, envPtr);
|
||
TclAdjustStackDepth(-(numLists+2), envPtr);
|
||
|
||
/*
|
||
* Set the jumpback distance from INST_FOREACH_STEP to the start of the
|
||
* body's code. Misuse loopCtTemp for storing the jump size.
|
||
*/
|
||
|
||
jumpBackOffset = envPtr->exceptArrayPtr[range].continueOffset -
|
||
envPtr->exceptArrayPtr[range].codeOffset;
|
||
infoPtr->loopCtTemp = -jumpBackOffset;
|
||
|
||
/*
|
||
* The command's result is an empty string if not collecting. If
|
||
* collecting, it is automatically left on stack after FOREACH_END.
|
||
*/
|
||
|
||
if (collect != TCL_EACH_COLLECT) {
|
||
PushStringLiteral(envPtr, "");
|
||
}
|
||
|
||
done:
|
||
if (code == TCL_ERROR) {
|
||
FreeForeachInfo(infoPtr);
|
||
}
|
||
Tcl_DecrRefCount(varListObj);
|
||
return code;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* DupForeachInfo --
|
||
*
|
||
* 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
|
||
* structure is returned.
|
||
*
|
||
* 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.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static ClientData
|
||
DupForeachInfo(
|
||
ClientData clientData) /* The foreach command's compilation auxiliary
|
||
* data to duplicate. */
|
||
{
|
||
ForeachInfo *srcPtr = clientData;
|
||
ForeachInfo *dupPtr;
|
||
ForeachVarList *srcListPtr, *dupListPtr;
|
||
int numVars, i, j, numLists = srcPtr->numLists;
|
||
|
||
dupPtr = ckalloc(TclOffset(ForeachInfo, varLists)
|
||
+ 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 = ckalloc(TclOffset(ForeachVarList, varIndexes)
|
||
+ numVars * sizeof(int));
|
||
dupListPtr->numVars = numVars;
|
||
for (j = 0; j < numVars; j++) {
|
||
dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j];
|
||
}
|
||
dupPtr->varLists[i] = dupListPtr;
|
||
}
|
||
return dupPtr;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* FreeForeachInfo --
|
||
*
|
||
* Procedure to free a ForeachInfo structure created as auxiliary data
|
||
* during the compilation of a foreach command.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* Storage for the ForeachInfo structure pointed to by the ClientData
|
||
* argument is freed as is any ForeachVarList record pointed to by the
|
||
* ForeachInfo structure.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static void
|
||
FreeForeachInfo(
|
||
ClientData clientData) /* The foreach command's compilation auxiliary
|
||
* data to free. */
|
||
{
|
||
ForeachInfo *infoPtr = clientData;
|
||
ForeachVarList *listPtr;
|
||
int numLists = infoPtr->numLists;
|
||
int i;
|
||
|
||
for (i = 0; i < numLists; i++) {
|
||
listPtr = infoPtr->varLists[i];
|
||
ckfree(listPtr);
|
||
}
|
||
ckfree(infoPtr);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* PrintForeachInfo, DisassembleForeachInfo --
|
||
*
|
||
* Functions to write a human-readable or script-readablerepresentation
|
||
* of a ForeachInfo structure to a Tcl_Obj for debugging.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static void
|
||
PrintForeachInfo(
|
||
ClientData clientData,
|
||
Tcl_Obj *appendObj,
|
||
ByteCode *codePtr,
|
||
unsigned int pcOffset)
|
||
{
|
||
ForeachInfo *infoPtr = clientData;
|
||
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);
|
||
}
|
||
}
|
||
|
||
static void
|
||
PrintNewForeachInfo(
|
||
ClientData clientData,
|
||
Tcl_Obj *appendObj,
|
||
ByteCode *codePtr,
|
||
unsigned int pcOffset)
|
||
{
|
||
ForeachInfo *infoPtr = clientData;
|
||
ForeachVarList *varsPtr;
|
||
int i, j;
|
||
|
||
Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+d, vars=",
|
||
infoPtr->loopCtTemp);
|
||
for (i=0 ; i<infoPtr->numLists ; i++) {
|
||
if (i) {
|
||
Tcl_AppendToObj(appendObj, ",", -1);
|
||
}
|
||
Tcl_AppendToObj(appendObj, "[", -1);
|
||
varsPtr = infoPtr->varLists[i];
|
||
for (j=0 ; j<varsPtr->numVars ; j++) {
|
||
if (j) {
|
||
Tcl_AppendToObj(appendObj, ",", -1);
|
||
}
|
||
Tcl_AppendPrintfToObj(appendObj, "%%v%u",
|
||
(unsigned) varsPtr->varIndexes[j]);
|
||
}
|
||
Tcl_AppendToObj(appendObj, "]", -1);
|
||
}
|
||
}
|
||
|
||
static void
|
||
DisassembleForeachInfo(
|
||
ClientData clientData,
|
||
Tcl_Obj *dictObj,
|
||
ByteCode *codePtr,
|
||
unsigned int pcOffset)
|
||
{
|
||
ForeachInfo *infoPtr = clientData;
|
||
ForeachVarList *varsPtr;
|
||
int i, j;
|
||
Tcl_Obj *objPtr, *innerPtr;
|
||
|
||
/*
|
||
* Data stores.
|
||
*/
|
||
|
||
objPtr = Tcl_NewObj();
|
||
for (i=0 ; i<infoPtr->numLists ; i++) {
|
||
Tcl_ListObjAppendElement(NULL, objPtr,
|
||
Tcl_NewIntObj(infoPtr->firstValueTemp + i));
|
||
}
|
||
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("data", -1), objPtr);
|
||
|
||
/*
|
||
* Loop counter.
|
||
*/
|
||
|
||
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("loop", -1),
|
||
Tcl_NewIntObj(infoPtr->loopCtTemp));
|
||
|
||
/*
|
||
* Assignment targets.
|
||
*/
|
||
|
||
objPtr = Tcl_NewObj();
|
||
for (i=0 ; i<infoPtr->numLists ; i++) {
|
||
innerPtr = Tcl_NewObj();
|
||
varsPtr = infoPtr->varLists[i];
|
||
for (j=0 ; j<varsPtr->numVars ; j++) {
|
||
Tcl_ListObjAppendElement(NULL, innerPtr,
|
||
Tcl_NewIntObj(varsPtr->varIndexes[j]));
|
||
}
|
||
Tcl_ListObjAppendElement(NULL, objPtr, innerPtr);
|
||
}
|
||
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr);
|
||
}
|
||
|
||
static void
|
||
DisassembleNewForeachInfo(
|
||
ClientData clientData,
|
||
Tcl_Obj *dictObj,
|
||
ByteCode *codePtr,
|
||
unsigned int pcOffset)
|
||
{
|
||
ForeachInfo *infoPtr = clientData;
|
||
ForeachVarList *varsPtr;
|
||
int i, j;
|
||
Tcl_Obj *objPtr, *innerPtr;
|
||
|
||
/*
|
||
* Jump offset.
|
||
*/
|
||
|
||
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("jumpOffset", -1),
|
||
Tcl_NewIntObj(infoPtr->loopCtTemp));
|
||
|
||
/*
|
||
* Assignment targets.
|
||
*/
|
||
|
||
objPtr = Tcl_NewObj();
|
||
for (i=0 ; i<infoPtr->numLists ; i++) {
|
||
innerPtr = Tcl_NewObj();
|
||
varsPtr = infoPtr->varLists[i];
|
||
for (j=0 ; j<varsPtr->numVars ; j++) {
|
||
Tcl_ListObjAppendElement(NULL, innerPtr,
|
||
Tcl_NewIntObj(varsPtr->varIndexes[j]));
|
||
}
|
||
Tcl_ListObjAppendElement(NULL, objPtr, innerPtr);
|
||
}
|
||
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileFormatCmd --
|
||
*
|
||
* Procedure called to compile the "format" command. Handles cases that
|
||
* can be done as constants or simple string concatenation only.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "format" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileFormatCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
|
||
Tcl_Obj **objv, *formatObj, *tmpObj;
|
||
char *bytes, *start;
|
||
int i, j, len;
|
||
|
||
/*
|
||
* Don't handle any guaranteed-error cases.
|
||
*/
|
||
|
||
if (parsePtr->numWords < 2) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Check if the argument words are all compile-time-known literals; that's
|
||
* a case we can handle by compiling to a constant.
|
||
*/
|
||
|
||
formatObj = Tcl_NewObj();
|
||
Tcl_IncrRefCount(formatObj);
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
if (!TclWordKnownAtCompileTime(tokenPtr, formatObj)) {
|
||
Tcl_DecrRefCount(formatObj);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
objv = ckalloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *));
|
||
for (i=0 ; i+2 < parsePtr->numWords ; i++) {
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
objv[i] = Tcl_NewObj();
|
||
Tcl_IncrRefCount(objv[i]);
|
||
if (!TclWordKnownAtCompileTime(tokenPtr, objv[i])) {
|
||
goto checkForStringConcatCase;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Everything is a literal, so the result is constant too (or an error if
|
||
* the format is broken). Do the format now.
|
||
*/
|
||
|
||
tmpObj = Tcl_Format(interp, Tcl_GetString(formatObj),
|
||
parsePtr->numWords-2, objv);
|
||
for (; --i>=0 ;) {
|
||
Tcl_DecrRefCount(objv[i]);
|
||
}
|
||
ckfree(objv);
|
||
Tcl_DecrRefCount(formatObj);
|
||
if (tmpObj == NULL) {
|
||
TclCompileSyntaxError(interp, envPtr);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* Not an error, always a constant result, so just push the result as a
|
||
* literal. Job done.
|
||
*/
|
||
|
||
bytes = Tcl_GetStringFromObj(tmpObj, &len);
|
||
PushLiteral(envPtr, bytes, len);
|
||
Tcl_DecrRefCount(tmpObj);
|
||
return TCL_OK;
|
||
|
||
checkForStringConcatCase:
|
||
/*
|
||
* See if we can generate a sequence of things to concatenate. This
|
||
* requires that all the % sequences be %s or %%, as everything else is
|
||
* sufficiently complex that we don't bother.
|
||
*
|
||
* First, get the state of the system relatively sensible (cleaning up
|
||
* after our attempt to spot a literal).
|
||
*/
|
||
|
||
for (; i>=0 ; i--) {
|
||
Tcl_DecrRefCount(objv[i]);
|
||
}
|
||
ckfree(objv);
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
i = 0;
|
||
|
||
/*
|
||
* Now scan through and check for non-%s and non-%% substitutions.
|
||
*/
|
||
|
||
for (bytes = Tcl_GetString(formatObj) ; *bytes ; bytes++) {
|
||
if (*bytes == '%') {
|
||
bytes++;
|
||
if (*bytes == 's') {
|
||
i++;
|
||
continue;
|
||
} else if (*bytes == '%') {
|
||
continue;
|
||
}
|
||
Tcl_DecrRefCount(formatObj);
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Check if the number of things to concatenate will fit in a byte.
|
||
*/
|
||
|
||
if (i+2 != parsePtr->numWords || i > 125) {
|
||
Tcl_DecrRefCount(formatObj);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Generate the pushes of the things to concatenate, a sequence of
|
||
* literals and compiled tokens (of which at least one is non-literal or
|
||
* we'd have the case in the first half of this function) which we will
|
||
* concatenate.
|
||
*/
|
||
|
||
i = 0; /* The count of things to concat. */
|
||
j = 2; /* The index into the argument tokens, for
|
||
* TIP#280 handling. */
|
||
start = Tcl_GetString(formatObj);
|
||
/* The start of the currently-scanned literal
|
||
* in the format string. */
|
||
tmpObj = Tcl_NewObj(); /* The buffer used to accumulate the literal
|
||
* being built. */
|
||
for (bytes = start ; *bytes ; bytes++) {
|
||
if (*bytes == '%') {
|
||
Tcl_AppendToObj(tmpObj, start, bytes - start);
|
||
if (*++bytes == '%') {
|
||
Tcl_AppendToObj(tmpObj, "%", 1);
|
||
} else {
|
||
char *b = Tcl_GetStringFromObj(tmpObj, &len);
|
||
|
||
/*
|
||
* If there is a non-empty literal from the format string,
|
||
* push it and reset.
|
||
*/
|
||
|
||
if (len > 0) {
|
||
PushLiteral(envPtr, b, len);
|
||
Tcl_DecrRefCount(tmpObj);
|
||
tmpObj = Tcl_NewObj();
|
||
i++;
|
||
}
|
||
|
||
/*
|
||
* Push the code to produce the string that would be
|
||
* substituted with %s, except we'll be concatenating
|
||
* directly.
|
||
*/
|
||
|
||
CompileWord(envPtr, tokenPtr, interp, j);
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
j++;
|
||
i++;
|
||
}
|
||
start = bytes + 1;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Handle the case of a trailing literal.
|
||
*/
|
||
|
||
Tcl_AppendToObj(tmpObj, start, bytes - start);
|
||
bytes = Tcl_GetStringFromObj(tmpObj, &len);
|
||
if (len > 0) {
|
||
PushLiteral(envPtr, bytes, len);
|
||
i++;
|
||
}
|
||
Tcl_DecrRefCount(tmpObj);
|
||
Tcl_DecrRefCount(formatObj);
|
||
|
||
if (i > 1) {
|
||
/*
|
||
* Do the concatenation, which produces the result.
|
||
*/
|
||
|
||
TclEmitInstInt1(INST_STR_CONCAT1, i, envPtr);
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclLocalScalarFromToken --
|
||
*
|
||
* Get the index into the table of compiled locals that corresponds
|
||
* to a local scalar variable name.
|
||
*
|
||
* Results:
|
||
* Returns the non-negative integer index value into the table of
|
||
* compiled locals corresponding to a local scalar variable name.
|
||
* If the arguments passed in do not identify a local scalar variable
|
||
* then return -1.
|
||
*
|
||
* Side effects:
|
||
* May add an entery into the table of compiled locals.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclLocalScalarFromToken(
|
||
Tcl_Token *tokenPtr,
|
||
CompileEnv *envPtr)
|
||
{
|
||
int isScalar, index;
|
||
|
||
TclPushVarName(NULL, tokenPtr, envPtr, TCL_NO_ELEMENT, &index, &isScalar);
|
||
if (!isScalar) {
|
||
index = -1;
|
||
}
|
||
return index;
|
||
}
|
||
|
||
int
|
||
TclLocalScalar(
|
||
const char *bytes,
|
||
int numBytes,
|
||
CompileEnv *envPtr)
|
||
{
|
||
Tcl_Token token[2] = {{TCL_TOKEN_SIMPLE_WORD, NULL, 0, 1},
|
||
{TCL_TOKEN_TEXT, NULL, 0, 0}};
|
||
|
||
token[1].start = bytes;
|
||
token[1].size = numBytes;
|
||
return TclLocalScalarFromToken(token, envPtr);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclPushVarName --
|
||
*
|
||
* Procedure used in the compiling where pushing a variable name is
|
||
* necessary (append, lappend, set).
|
||
*
|
||
* Results:
|
||
* The values written to *localIndexPtr and *isScalarPtr signal to
|
||
* the caller what the instructions emitted by this routine will do:
|
||
*
|
||
* *isScalarPtr (*localIndexPtr < 0)
|
||
* 1 1 Push the varname on the stack. (Stack +1)
|
||
* 1 0 *localIndexPtr is the index of the compiled
|
||
* local for this varname. No instructions
|
||
* emitted. (Stack +0)
|
||
* 0 1 Push part1 and part2 names of array element
|
||
* on the stack. (Stack +2)
|
||
* 0 0 *localIndexPtr is the index of the compiled
|
||
* local for this array. Element name is pushed
|
||
* on the stack. (Stack +1)
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
void
|
||
TclPushVarName(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Token *varTokenPtr, /* Points to a variable token. */
|
||
CompileEnv *envPtr, /* Holds resulting instructions. */
|
||
int flags, /* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */
|
||
int *localIndexPtr, /* Must not be NULL. */
|
||
int *isScalarPtr) /* Must not be NULL. */
|
||
{
|
||
const char *p;
|
||
const char *last, *name, *elName;
|
||
int n;
|
||
Tcl_Token *elemTokenPtr = NULL;
|
||
int nameLen, elNameLen, 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.
|
||
*/
|
||
|
||
simpleVarName = 0;
|
||
name = elName = NULL;
|
||
nameLen = elNameLen = 0;
|
||
localIndex = -1;
|
||
|
||
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
|
||
/*
|
||
* 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;
|
||
nameLen = varTokenPtr[1].size;
|
||
if (name[nameLen-1] == ')') {
|
||
/*
|
||
* last char is ')' => potential array reference.
|
||
*/
|
||
last = &name[nameLen-1];
|
||
|
||
if (*last == ')') {
|
||
for (p = name; p < last; p++) {
|
||
if (*p == '(') {
|
||
elName = p + 1;
|
||
elNameLen = last - elName;
|
||
nameLen = p - name;
|
||
break;
|
||
}
|
||
}
|
||
}
|
||
|
||
if (!(flags & TCL_NO_ELEMENT) && elNameLen) {
|
||
/*
|
||
* An array element, the element name is a simple string:
|
||
* assemble the corresponding token.
|
||
*/
|
||
|
||
elemTokenPtr = TclStackAlloc(interp, sizeof(Tcl_Token));
|
||
allocedTokens = 1;
|
||
elemTokenPtr->type = TCL_TOKEN_TEXT;
|
||
elemTokenPtr->start = elName;
|
||
elemTokenPtr->size = elNameLen;
|
||
elemTokenPtr->numComponents = 0;
|
||
elemTokenCount = 1;
|
||
}
|
||
}
|
||
} else if (interp && ((n = varTokenPtr->numComponents) > 1)
|
||
&& (varTokenPtr[1].type == TCL_TOKEN_TEXT)
|
||
&& (varTokenPtr[n].type == TCL_TOKEN_TEXT)
|
||
&& (*(varTokenPtr[n].start + varTokenPtr[n].size - 1) == ')')) {
|
||
/*
|
||
* Check for parentheses inside first token.
|
||
*/
|
||
|
||
simpleVarName = 0;
|
||
for (p = varTokenPtr[1].start,
|
||
last = p + varTokenPtr[1].size; p < last; p++) {
|
||
if (*p == '(') {
|
||
simpleVarName = 1;
|
||
break;
|
||
}
|
||
}
|
||
if (simpleVarName) {
|
||
int remainingLen;
|
||
|
||
/*
|
||
* 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) {
|
||
n--;
|
||
} else {
|
||
varTokenPtr[n].size--;
|
||
removedParen = n;
|
||
}
|
||
|
||
name = varTokenPtr[1].start;
|
||
nameLen = p - varTokenPtr[1].start;
|
||
elName = p + 1;
|
||
remainingLen = (varTokenPtr[2].start - p) - 1;
|
||
elNameLen = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 1;
|
||
|
||
if (!(flags & TCL_NO_ELEMENT)) {
|
||
if (remainingLen) {
|
||
/*
|
||
* Make a first token with the extra characters in the first
|
||
* token.
|
||
*/
|
||
|
||
elemTokenPtr = TclStackAlloc(interp, n * sizeof(Tcl_Token));
|
||
allocedTokens = 1;
|
||
elemTokenPtr->type = TCL_TOKEN_TEXT;
|
||
elemTokenPtr->start = elName;
|
||
elemTokenPtr->size = remainingLen;
|
||
elemTokenPtr->numComponents = 0;
|
||
elemTokenCount = n;
|
||
|
||
/*
|
||
* Copy the remaining tokens.
|
||
*/
|
||
|
||
memcpy(elemTokenPtr+1, varTokenPtr+2,
|
||
(n-1) * sizeof(Tcl_Token));
|
||
} else {
|
||
/*
|
||
* Use the already available tokens.
|
||
*/
|
||
|
||
elemTokenPtr = &varTokenPtr[2];
|
||
elemTokenCount = n - 1;
|
||
}
|
||
}
|
||
}
|
||
}
|
||
|
||
if (simpleVarName) {
|
||
/*
|
||
* See whether name has any namespace separators (::'s).
|
||
*/
|
||
|
||
int hasNsQualifiers = 0;
|
||
|
||
for (p = name, last = p + nameLen-1; p < last; p++) {
|
||
if ((*p == ':') && (*(p+1) == ':')) {
|
||
hasNsQualifiers = 1;
|
||
break;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* 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 (!hasNsQualifiers) {
|
||
localIndex = TclFindCompiledLocal(name, nameLen, 1, envPtr);
|
||
if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
|
||
/*
|
||
* We'll push the name.
|
||
*/
|
||
|
||
localIndex = -1;
|
||
}
|
||
}
|
||
if (interp && localIndex < 0) {
|
||
PushLiteral(envPtr, name, nameLen);
|
||
}
|
||
|
||
/*
|
||
* Compile the element script, if any, and only if not inhibited. [Bug
|
||
* 3600328]
|
||
*/
|
||
|
||
if (elName != NULL && !(flags & TCL_NO_ELEMENT)) {
|
||
if (elNameLen) {
|
||
TclCompileTokens(interp, elemTokenPtr, elemTokenCount,
|
||
envPtr);
|
||
} else {
|
||
PushStringLiteral(envPtr, "");
|
||
}
|
||
}
|
||
} else if (interp) {
|
||
/*
|
||
* The var name isn't simple: compile and push it.
|
||
*/
|
||
|
||
CompileTokens(envPtr, varTokenPtr, interp);
|
||
}
|
||
|
||
if (removedParen) {
|
||
varTokenPtr[removedParen].size++;
|
||
}
|
||
if (allocedTokens) {
|
||
TclStackFree(interp, elemTokenPtr);
|
||
}
|
||
*localIndexPtr = localIndex;
|
||
*isScalarPtr = (elName == NULL);
|
||
}
|
||
|
||
/*
|
||
* Local Variables:
|
||
* mode: c
|
||
* c-basic-offset: 4
|
||
* fill-column: 78
|
||
* End:
|
||
*/
|