6387 lines
174 KiB
C
6387 lines
174 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-2006 by Donal K. Fellows.
|
||
*
|
||
* See the file "license.terms" for information on usage and redistribution of
|
||
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||
*/
|
||
|
||
#include "tclInt.h"
|
||
#include "tclCompile.h"
|
||
|
||
/*
|
||
* Macro that encapsulates an efficiency trick that avoids a function call for
|
||
* the simplest of compiles. The ANSI C "prototype" for this macro is:
|
||
*
|
||
* static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr,
|
||
* Tcl_Interp *interp, int word);
|
||
*/
|
||
|
||
#define CompileWord(envPtr, tokenPtr, interp, word) \
|
||
if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \
|
||
TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \
|
||
(tokenPtr)[1].size), (envPtr)); \
|
||
} else { \
|
||
envPtr->line = mapPtr->loc[eclIndex].line[word]; \
|
||
envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \
|
||
TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
|
||
(envPtr)); \
|
||
}
|
||
|
||
/*
|
||
* TIP #280: Remember the per-word line information of the current command. An
|
||
* index is used instead of a pointer as recursive compilation may reallocate,
|
||
* i.e. move, the array. This is also the reason to save the nuloc now, it may
|
||
* change during the course of the function.
|
||
*
|
||
* Macro to encapsulate the variable definition and setup.
|
||
*/
|
||
|
||
#define DefineLineInformation \
|
||
ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
|
||
int eclIndex = mapPtr->nuloc - 1
|
||
|
||
#define SetLineInformation(word) \
|
||
envPtr->line = mapPtr->loc [eclIndex].line [(word)]; \
|
||
envPtr->clNext = mapPtr->loc [eclIndex].next [(word)]
|
||
|
||
/*
|
||
* Convenience macro for use when compiling bodies of commands. The ANSI C
|
||
* "prototype" for this macro is:
|
||
*
|
||
* static void CompileBody(CompileEnv *envPtr, Tcl_Token *tokenPtr,
|
||
* Tcl_Interp *interp);
|
||
*/
|
||
|
||
#define CompileBody(envPtr, tokenPtr, interp) \
|
||
TclCompileCmdWord((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
|
||
(envPtr))
|
||
|
||
/*
|
||
* Convenience macro for use when compiling tokens to be pushed. The ANSI C
|
||
* "prototype" for this macro is:
|
||
*
|
||
* static void CompileTokens(CompileEnv *envPtr, Tcl_Token *tokenPtr,
|
||
* Tcl_Interp *interp);
|
||
*/
|
||
|
||
#define CompileTokens(envPtr, tokenPtr, interp) \
|
||
TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
|
||
(envPtr));
|
||
/*
|
||
* Convenience macro for use when pushing literals. The ANSI C "prototype" for
|
||
* this macro is:
|
||
*
|
||
* static void PushLiteral(CompileEnv *envPtr,
|
||
* const char *string, int length);
|
||
*/
|
||
|
||
#define PushLiteral(envPtr, string, length) \
|
||
TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr))
|
||
|
||
/*
|
||
* Macro to advance to the next token; it is more mnemonic than the address
|
||
* arithmetic that it replaces. The ANSI C "prototype" for this macro is:
|
||
*
|
||
* static Tcl_Token * TokenAfter(Tcl_Token *tokenPtr);
|
||
*/
|
||
|
||
#define TokenAfter(tokenPtr) \
|
||
((tokenPtr) + ((tokenPtr)->numComponents + 1))
|
||
|
||
/*
|
||
* Macro to get the offset to the next instruction to be issued. The ANSI C
|
||
* "prototype" for this macro is:
|
||
*
|
||
* static int CurrentOffset(CompileEnv *envPtr);
|
||
*/
|
||
|
||
#define CurrentOffset(envPtr) \
|
||
((envPtr)->codeNext - (envPtr)->codeStart)
|
||
|
||
/*
|
||
* Note: the exceptDepth is a bit of a misnomer: TEBC only needs the
|
||
* maximal depth of nested CATCH ranges in order to alloc runtime
|
||
* memory. These macros should compute precisely that? OTOH, the nesting depth
|
||
* of LOOP ranges is an interesting datum for debugging purposes, and that is
|
||
* what we compute now.
|
||
*
|
||
* static int DeclareExceptionRange(CompileEnv *envPtr, int type);
|
||
* static int ExceptionRangeStarts(CompileEnv *envPtr, int index);
|
||
* static void ExceptionRangeEnds(CompileEnv *envPtr, int index);
|
||
* static void ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL);
|
||
*/
|
||
|
||
#define DeclareExceptionRange(envPtr, type) \
|
||
(TclCreateExceptRange((type), (envPtr)))
|
||
#define ExceptionRangeStarts(envPtr, index) \
|
||
(((envPtr)->exceptDepth++), \
|
||
((envPtr)->maxExceptDepth = \
|
||
TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \
|
||
((envPtr)->exceptArrayPtr[(index)].codeOffset = CurrentOffset(envPtr)))
|
||
#define ExceptionRangeEnds(envPtr, index) \
|
||
(((envPtr)->exceptDepth--), \
|
||
((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \
|
||
CurrentOffset(envPtr) - (envPtr)->exceptArrayPtr[(index)].codeOffset))
|
||
#define ExceptionRangeTarget(envPtr, index, targetType) \
|
||
((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr))
|
||
|
||
/*
|
||
* 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 ClientData DupForeachInfo(ClientData clientData);
|
||
static void FreeForeachInfo(ClientData clientData);
|
||
static void PrintForeachInfo(ClientData clientData,
|
||
Tcl_Obj *appendObj, ByteCode *codePtr,
|
||
unsigned int pcOffset);
|
||
static ClientData DupJumptableInfo(ClientData clientData);
|
||
static void FreeJumptableInfo(ClientData clientData);
|
||
static void PrintJumptableInfo(ClientData clientData,
|
||
Tcl_Obj *appendObj, ByteCode *codePtr,
|
||
unsigned int pcOffset);
|
||
static int LocalScalarFromToken(Tcl_Token *tokenPtr,
|
||
CompileEnv *envPtr);
|
||
static int LocalScalar(const char *bytes, int numBytes,
|
||
CompileEnv *envPtr);
|
||
static int PushVarName(Tcl_Interp *interp,
|
||
Tcl_Token *varTokenPtr, CompileEnv *envPtr,
|
||
int flags, int *localIndexPtr,
|
||
int *simpleVarNamePtr, int *isScalarPtr,
|
||
int line, int* clNext);
|
||
static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr, const char *identity,
|
||
int instruction, CompileEnv *envPtr);
|
||
static int CompileComparisonOpCmd(Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr, int instruction,
|
||
CompileEnv *envPtr);
|
||
static int CompileStrictlyBinaryOpCmd(Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr, int instruction,
|
||
CompileEnv *envPtr);
|
||
static int CompileUnaryOpCmd(Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr, int instruction,
|
||
CompileEnv *envPtr);
|
||
static void CompileReturnInternal(CompileEnv *envPtr,
|
||
unsigned char op, int code, int level,
|
||
Tcl_Obj *returnOpts);
|
||
|
||
#define PushVarNameWord(i,v,e,f,l,s,sc,word) \
|
||
PushVarName (i,v,e,f,l,s,sc, \
|
||
mapPtr->loc [eclIndex].line [(word)], \
|
||
mapPtr->loc [eclIndex].next [(word)])
|
||
|
||
/*
|
||
* Flags bits used by PushVarName.
|
||
*/
|
||
|
||
#define TCL_CREATE_VAR 1 /* Create a compiled local if none is found */
|
||
#define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */
|
||
|
||
/*
|
||
* The structures below define the AuxData types defined in this file.
|
||
*/
|
||
|
||
AuxDataType tclForeachInfoType = {
|
||
"ForeachInfo", /* name */
|
||
DupForeachInfo, /* dupProc */
|
||
FreeForeachInfo, /* freeProc */
|
||
PrintForeachInfo /* printProc */
|
||
};
|
||
|
||
AuxDataType tclJumptableInfoType = {
|
||
"JumptableInfo", /* name */
|
||
DupJumptableInfo, /* dupProc */
|
||
FreeJumptableInfo, /* freeProc */
|
||
PrintJumptableInfo /* printProc */
|
||
};
|
||
|
||
AuxDataType tclDictUpdateInfoType = {
|
||
"DictUpdateInfo", /* name */
|
||
DupDictUpdateInfo, /* dupProc */
|
||
FreeDictUpdateInfo, /* freeProc */
|
||
PrintDictUpdateInfo /* printProc */
|
||
};
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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. */
|
||
{
|
||
Tcl_Token *varTokenPtr, *valueTokenPtr;
|
||
int simpleVarName, isScalar, localIndex, numWords;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
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.
|
||
*/
|
||
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Decide if we can use a frame slot for the var/array name or if we need
|
||
* to emit code to compute and push the name at runtime. We use a frame
|
||
* slot (entry in the array of local vars) if we are compiling a procedure
|
||
* body and if the name is simple text that does not include namespace
|
||
* qualifiers.
|
||
*/
|
||
|
||
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
|
||
PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
|
||
&localIndex, &simpleVarName, &isScalar, 1);
|
||
|
||
/*
|
||
* We are doing an assignment, otherwise TclCompileSetCmd was called, so
|
||
* push the new value. This will need to be extended to push a value for
|
||
* each argument.
|
||
*/
|
||
|
||
if (numWords > 2) {
|
||
valueTokenPtr = TokenAfter(varTokenPtr);
|
||
CompileWord(envPtr, valueTokenPtr, interp, 2);
|
||
}
|
||
|
||
/*
|
||
* Emit instructions to set/get the variable.
|
||
*/
|
||
|
||
if (simpleVarName) {
|
||
if (isScalar) {
|
||
if (localIndex < 0) {
|
||
TclEmitOpcode(INST_APPEND_STK, envPtr);
|
||
} else if (localIndex <= 255) {
|
||
TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr);
|
||
} else {
|
||
TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr);
|
||
}
|
||
} else {
|
||
if (localIndex < 0) {
|
||
TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr);
|
||
} else if (localIndex <= 255) {
|
||
TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr);
|
||
} else {
|
||
TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr);
|
||
}
|
||
}
|
||
} else {
|
||
TclEmitOpcode(INST_APPEND_STK, envPtr);
|
||
}
|
||
|
||
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. */
|
||
{
|
||
if (parsePtr->numWords != 1) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Emit a break instruction.
|
||
*/
|
||
|
||
TclEmitOpcode(INST_BREAK, 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. */
|
||
{
|
||
JumpFixup jumpFixup;
|
||
Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr;
|
||
int resultIndex, optsIndex, range;
|
||
int initStackDepth = envPtr->currStackDepth;
|
||
int savedStackDepth;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
/*
|
||
* 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;
|
||
}
|
||
|
||
/*
|
||
* 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.
|
||
*/
|
||
|
||
range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
|
||
|
||
/*
|
||
* If the body is a simple word, compile a BEGIN_CATCH instruction,
|
||
* followed by the instructions to eval the body.
|
||
* Otherwise, compile instructions to substitute the body text before
|
||
* starting the catch, then BEGIN_CATCH, and then EVAL_STK to
|
||
* evaluate the substituted body.
|
||
* Care has to be taken to make sure that substitution happens outside
|
||
* the catch range so that errors in the substitution are not caught.
|
||
* [Bug 219184]
|
||
* The reason for duplicating the script is that EVAL_STK would otherwise
|
||
* begin by undeflowing the stack below the mark set by BEGIN_CATCH4.
|
||
*/
|
||
|
||
SetLineInformation(1);
|
||
if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
|
||
savedStackDepth = envPtr->currStackDepth;
|
||
TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);
|
||
ExceptionRangeStarts(envPtr, range);
|
||
CompileBody(envPtr, cmdTokenPtr, interp);
|
||
} else {
|
||
CompileTokens(envPtr, cmdTokenPtr, interp);
|
||
savedStackDepth = envPtr->currStackDepth;
|
||
TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);
|
||
ExceptionRangeStarts(envPtr, range);
|
||
TclEmitOpcode(INST_DUP, envPtr);
|
||
TclEmitOpcode(INST_EVAL_STK, envPtr);
|
||
}
|
||
/* Stack at this point:
|
||
* nonsimple: script <mark> result
|
||
* simple: <mark> result
|
||
*/
|
||
|
||
/*
|
||
* Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch
|
||
* result, and jump around the "error case" code.
|
||
*/
|
||
|
||
PushLiteral(envPtr, "0", 1);
|
||
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
|
||
/* Stack at this point: ?script? <mark> result TCL_OK */
|
||
|
||
/*
|
||
* Emit the "error case" epilogue. Push the interpreter result
|
||
* and the return code.
|
||
*/
|
||
|
||
envPtr->currStackDepth = savedStackDepth;
|
||
ExceptionRangeTarget(envPtr, range, catchOffset);
|
||
/* Stack at this point: ?script? */
|
||
TclEmitOpcode(INST_PUSH_RESULT, envPtr);
|
||
TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
|
||
|
||
/*
|
||
* Update the target of the jump after the "no errors" code.
|
||
*/
|
||
|
||
/* Stack at this point: ?script? result returnCode */
|
||
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
|
||
Tcl_Panic("TclCompileCatchCmd: bad jump distance %d",
|
||
(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
|
||
}
|
||
|
||
/* Push the return options if the caller wants them */
|
||
|
||
if (optsIndex != -1) {
|
||
TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr);
|
||
}
|
||
|
||
/*
|
||
* End the catch
|
||
*/
|
||
|
||
ExceptionRangeEnds(envPtr, range);
|
||
TclEmitOpcode(INST_END_CATCH, envPtr);
|
||
|
||
/*
|
||
* At this point, the top of the stack is inconveniently ordered:
|
||
* ?script? result returnCode ?returnOptions?
|
||
* Reverse the stack to bring the result to the top.
|
||
*/
|
||
|
||
if (optsIndex != -1) {
|
||
TclEmitInstInt4(INST_REVERSE, 3, envPtr);
|
||
} else {
|
||
TclEmitInstInt4(INST_REVERSE, 2, envPtr);
|
||
}
|
||
|
||
/*
|
||
* Store the result if requested, and remove it from the stack
|
||
*/
|
||
|
||
if (resultIndex != -1) {
|
||
if (resultIndex <= 255) {
|
||
TclEmitInstInt1(INST_STORE_SCALAR1, resultIndex, envPtr);
|
||
} else {
|
||
TclEmitInstInt4(INST_STORE_SCALAR4, resultIndex, envPtr);
|
||
}
|
||
}
|
||
TclEmitOpcode(INST_POP, envPtr);
|
||
|
||
/*
|
||
* Stack is now ?script? ?returnOptions? returnCode.
|
||
* If the options dict has been requested, it is buried on the stack
|
||
* under the return code. Reverse the stack to bring it to the top,
|
||
* store it and remove it from the stack.
|
||
*/
|
||
|
||
if (optsIndex != -1) {
|
||
TclEmitInstInt4(INST_REVERSE, 2, envPtr);
|
||
if (optsIndex <= 255) {
|
||
TclEmitInstInt1(INST_STORE_SCALAR1, optsIndex, envPtr);
|
||
} else {
|
||
TclEmitInstInt4(INST_STORE_SCALAR4, optsIndex, envPtr);
|
||
}
|
||
TclEmitOpcode(INST_POP, envPtr);
|
||
}
|
||
|
||
/*
|
||
* Stack is now ?script? result. Get rid of the subst'ed script
|
||
* if it's hanging arond.
|
||
*/
|
||
|
||
if (cmdTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
|
||
TclEmitInstInt4(INST_REVERSE, 2, envPtr);
|
||
TclEmitOpcode(INST_POP, envPtr);
|
||
}
|
||
|
||
/*
|
||
* Result of all this, on either branch, should have been to leave
|
||
* one operand -- the return code -- on the stack.
|
||
*/
|
||
|
||
if (envPtr->currStackDepth != initStackDepth + 1) {
|
||
Tcl_Panic("in TclCompileCatchCmd, currStackDepth = %d should be %d",
|
||
envPtr->currStackDepth, initStackDepth+1);
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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. */
|
||
{
|
||
/*
|
||
* There should be no argument after the "continue".
|
||
*/
|
||
|
||
if (parsePtr->numWords != 1) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Emit a continue instruction.
|
||
*/
|
||
|
||
TclEmitOpcode(INST_CONTINUE, 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.
|
||
*
|
||
* Notes:
|
||
* The following commands are in fairly common use and are possibly worth
|
||
* bytecoding:
|
||
* dict append
|
||
* dict create [*]
|
||
* dict exists [*]
|
||
* dict for
|
||
* dict get [*]
|
||
* dict incr
|
||
* dict keys [*]
|
||
* dict lappend
|
||
* dict set
|
||
* dict unset
|
||
*
|
||
* In practice, those that are pure-value operators (marked with [*]) can
|
||
* probably be left alone (except perhaps [dict get] which is very very
|
||
* common) and [dict update] should be considered instead (really big
|
||
* win!)
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileDictSetCmd(
|
||
Tcl_Interp *interp, /* Used for looking up stuff. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
Tcl_Token *tokenPtr, *varTokenPtr;
|
||
int i, dictVarIndex;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
/*
|
||
* There must be at least three arguments after the (sub-)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);
|
||
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. */
|
||
{
|
||
Tcl_Token *varTokenPtr, *keyTokenPtr;
|
||
int dictVarIndex, incrAmount;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
/*
|
||
* There must be at least two arguments after the command.
|
||
*/
|
||
|
||
if (parsePtr->numWords < 3 || parsePtr->numWords > 4) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* The dictionary variable must be a local scalar that is knowable at
|
||
* compile time; anything else exceeds the complexity of the opcode. So
|
||
* discover what the index is.
|
||
*/
|
||
|
||
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr);
|
||
if (dictVarIndex < 0) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
keyTokenPtr = TokenAfter(varTokenPtr);
|
||
|
||
/*
|
||
* Parse the increment amount, if present.
|
||
*/
|
||
|
||
if (parsePtr->numWords == 4) {
|
||
Tcl_Token *incrTokenPtr = TokenAfter(keyTokenPtr);
|
||
Tcl_Obj *intObj = Tcl_NewObj();
|
||
int fail = (!TclWordKnownAtCompileTime(incrTokenPtr, intObj)
|
||
|| TCL_ERROR == TclGetIntFromObj(NULL, intObj, &incrAmount));
|
||
Tcl_DecrRefCount(intObj);
|
||
if (fail) {
|
||
return TCL_ERROR;
|
||
}
|
||
} else {
|
||
incrAmount = 1;
|
||
}
|
||
|
||
/*
|
||
* 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. */
|
||
{
|
||
Tcl_Token *tokenPtr;
|
||
int i;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
/*
|
||
* There must be at least two arguments after the command (the single-arg
|
||
* case is legal, but too special and magic for us to deal with here).
|
||
*/
|
||
|
||
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);
|
||
return TCL_OK;
|
||
}
|
||
|
||
int
|
||
TclCompileDictForCmd(
|
||
Tcl_Interp *interp, /* Used for looking up stuff. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
Proc *procPtr = envPtr->procPtr;
|
||
Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr;
|
||
int keyVarIndex, valueVarIndex, loopRange, catchRange;
|
||
int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset;
|
||
int numVars, endTargetOffset, numBytes;
|
||
const char *bytes;
|
||
int savedStackDepth = envPtr->currStackDepth;
|
||
/* Needed because jumps confuse the stack
|
||
* space calculator. */
|
||
Tcl_Obj *varNameObj, *varListObj = NULL;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
/*
|
||
* There must be exactly three arguments after the command.
|
||
*/
|
||
|
||
if (parsePtr->numWords != 4 || procPtr == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
varsTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
dictTokenPtr = TokenAfter(varsTokenPtr);
|
||
bodyTokenPtr = TokenAfter(dictTokenPtr);
|
||
|
||
if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Check we've got a pair of variables and that they are local variables.
|
||
* Then extract their indices in the LVT.
|
||
*/
|
||
|
||
varListObj = Tcl_NewObj();
|
||
if (!TclWordKnownAtCompileTime(varsTokenPtr, varListObj) ||
|
||
TCL_OK != Tcl_ListObjLength(NULL, varListObj, &numVars) ||
|
||
numVars != 2) {
|
||
Tcl_DecrRefCount(varListObj);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
Tcl_ListObjIndex(NULL, varListObj, 0, &varNameObj);
|
||
bytes = Tcl_GetStringFromObj(varNameObj, &numBytes);
|
||
keyVarIndex = LocalScalar(bytes, numBytes, envPtr);
|
||
if (keyVarIndex < 0) {
|
||
Tcl_DecrRefCount(varListObj);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
Tcl_ListObjIndex(NULL, varListObj, 1, &varNameObj);
|
||
bytes = Tcl_GetStringFromObj(varNameObj, &numBytes);
|
||
valueVarIndex = LocalScalar(bytes, numBytes, envPtr);
|
||
if (valueVarIndex < 0) {
|
||
Tcl_DecrRefCount(varListObj);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
Tcl_DecrRefCount(varListObj);
|
||
|
||
/*
|
||
* Allocate a temporary variable to store the iterator reference. The
|
||
* variable will contain a Tcl_DictSearch reference which will be
|
||
* allocated by INST_DICT_FIRST and disposed when the variable is unset
|
||
* (at which point it should also have been finished with).
|
||
*/
|
||
|
||
infoIndex = TclFindCompiledLocal(NULL, 0, 1, procPtr);
|
||
|
||
/*
|
||
* Preparation complete; issue instructions. Note that this code issues
|
||
* fixed-sized jumps. That simplifies things a lot!
|
||
*
|
||
* First up, get the dictionary and start the iteration. No catching of
|
||
* errors at this point.
|
||
*/
|
||
|
||
CompileWord(envPtr, dictTokenPtr, interp, 2);
|
||
TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr);
|
||
emptyTargetOffset = CurrentOffset(envPtr);
|
||
TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr);
|
||
|
||
/*
|
||
* Now we catch errors from here on so that we can finalize the search
|
||
* started by Tcl_DictObjFirst above.
|
||
*/
|
||
|
||
catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
|
||
TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr);
|
||
ExceptionRangeStarts(envPtr, catchRange);
|
||
|
||
/*
|
||
* Inside the iteration, write the loop variables.
|
||
*/
|
||
|
||
bodyTargetOffset = CurrentOffset(envPtr);
|
||
TclEmitInstInt4( INST_STORE_SCALAR4, keyVarIndex, envPtr);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
TclEmitInstInt4( INST_STORE_SCALAR4, valueVarIndex, envPtr);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
|
||
/*
|
||
* Set up the loop exception targets.
|
||
*/
|
||
|
||
loopRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
|
||
ExceptionRangeStarts(envPtr, loopRange);
|
||
|
||
/*
|
||
* Compile the loop body itself. It should be stack-neutral.
|
||
*/
|
||
|
||
SetLineInformation(3);
|
||
CompileBody(envPtr, bodyTokenPtr, interp);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
|
||
/*
|
||
* Both exception target ranges (error and loop) end here.
|
||
*/
|
||
|
||
ExceptionRangeEnds(envPtr, loopRange);
|
||
ExceptionRangeEnds(envPtr, catchRange);
|
||
|
||
/*
|
||
* Continue (or just normally process) by getting the next pair of items
|
||
* from the dictionary and jumping back to the code to write them into
|
||
* variables if there is another pair.
|
||
*/
|
||
|
||
ExceptionRangeTarget(envPtr, loopRange, continueOffset);
|
||
TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr);
|
||
jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr);
|
||
TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
|
||
/*
|
||
* Now do the final cleanup for the no-error case (this is where we break
|
||
* out of the loop to) by force-terminating the iteration (if not already
|
||
* terminated), ditching the exception info and jumping to the last
|
||
* instruction for this command. In theory, this could be done using the
|
||
* "finally" clause (next generated) but this is faster.
|
||
*/
|
||
|
||
ExceptionRangeTarget(envPtr, loopRange, breakOffset);
|
||
TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr);
|
||
TclEmitOpcode( INST_END_CATCH, envPtr);
|
||
endTargetOffset = CurrentOffset(envPtr);
|
||
TclEmitInstInt4( INST_JUMP4, 0, envPtr);
|
||
|
||
/*
|
||
* Error handler "finally" clause, which force-terminates the iteration
|
||
* and rethrows the error.
|
||
*/
|
||
|
||
ExceptionRangeTarget(envPtr, catchRange, catchOffset);
|
||
TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
|
||
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
|
||
TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr);
|
||
TclEmitOpcode( INST_END_CATCH, envPtr);
|
||
TclEmitOpcode( INST_RETURN_STK, envPtr);
|
||
|
||
/*
|
||
* Otherwise we're done (the jump after the DICT_FIRST points here) and we
|
||
* need to pop the bogus key/value pair (pushed to keep stack calculations
|
||
* easy!) Note that we skip the END_CATCH. [Bug 1382528]
|
||
*/
|
||
|
||
envPtr->currStackDepth = savedStackDepth+2;
|
||
jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset;
|
||
TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement,
|
||
envPtr->codeStart + emptyTargetOffset);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
TclEmitOpcode( INST_POP, envPtr);
|
||
TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr);
|
||
|
||
/*
|
||
* Final stage of the command (normal case) is that we push an empty
|
||
* object. This is done last to promote peephole optimization when it's
|
||
* dropped immediately.
|
||
*/
|
||
|
||
jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset;
|
||
TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement,
|
||
envPtr->codeStart + endTargetOffset);
|
||
PushLiteral(envPtr, "", 0);
|
||
return TCL_OK;
|
||
}
|
||
|
||
int
|
||
TclCompileDictUpdateCmd(
|
||
Tcl_Interp *interp, /* Used for looking up stuff. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
int i, dictIndex, numVars, range, infoIndex;
|
||
Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr, *tokenPtr;
|
||
DictUpdateInfo *duiPtr;
|
||
JumpFixup jumpFixup;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
/*
|
||
* 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;
|
||
if (numVars < 1) {
|
||
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.
|
||
*/
|
||
|
||
dictVarTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
dictIndex = LocalScalarFromToken(dictVarTokenPtr, envPtr);
|
||
if (dictIndex < 0) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Assemble the instruction metadata. This is complex enough that it is
|
||
* represented as auxData; it holds an ordered list of variable indices
|
||
* that are to be used.
|
||
*/
|
||
|
||
duiPtr = (DictUpdateInfo *)
|
||
ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1));
|
||
duiPtr->length = numVars;
|
||
keyTokenPtrs = (Tcl_Token **) TclStackAlloc(interp,
|
||
sizeof(Tcl_Token *) * numVars);
|
||
tokenPtr = TokenAfter(dictVarTokenPtr);
|
||
|
||
for (i=0 ; i<numVars ; i++) {
|
||
int index;
|
||
|
||
/*
|
||
* Put keys to one side for later compilation to bytecode.
|
||
*/
|
||
|
||
keyTokenPtrs[i] = tokenPtr;
|
||
|
||
/*
|
||
* Variables first need to be checked for sanity.
|
||
*/
|
||
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
index = LocalScalarFromToken(tokenPtr, envPtr);
|
||
if (index < 0) {
|
||
ckfree((char *) duiPtr);
|
||
TclStackFree(interp, keyTokenPtrs);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Stash the index in the auxiliary data.
|
||
*/
|
||
|
||
duiPtr->varIndices[i] = index;
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
}
|
||
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
|
||
ckfree((char *) duiPtr);
|
||
TclStackFree(interp, keyTokenPtrs);
|
||
return TCL_ERROR;
|
||
}
|
||
bodyTokenPtr = tokenPtr;
|
||
|
||
/*
|
||
* The list of variables to bind is stored in auxiliary data so that it
|
||
* can't be snagged by literal sharing and forced to shimmer dangerously.
|
||
*/
|
||
|
||
infoIndex = TclCreateAuxData(duiPtr, &tclDictUpdateInfoType, envPtr);
|
||
|
||
for (i=0 ; i<numVars ; i++) {
|
||
CompileWord(envPtr, keyTokenPtrs[i], interp, 2*i+2);
|
||
}
|
||
TclEmitInstInt4( INST_LIST, numVars, envPtr);
|
||
TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr);
|
||
TclEmitInt4( infoIndex, envPtr);
|
||
|
||
range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
|
||
TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
|
||
|
||
ExceptionRangeStarts(envPtr, range);
|
||
SetLineInformation(parsePtr->numWords - 1);
|
||
CompileBody(envPtr, bodyTokenPtr, interp);
|
||
ExceptionRangeEnds(envPtr, range);
|
||
|
||
/*
|
||
* Normal termination code: the stack has the key list below the result of
|
||
* the body evaluation: swap them and finish the update code.
|
||
*/
|
||
|
||
TclEmitOpcode( INST_END_CATCH, envPtr);
|
||
TclEmitInstInt4( INST_REVERSE, 2, envPtr);
|
||
TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
|
||
TclEmitInt4( infoIndex, envPtr);
|
||
|
||
/*
|
||
* Jump around the exceptional termination code.
|
||
*/
|
||
|
||
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
|
||
|
||
/*
|
||
* Termination code for non-ok returns: stash the result and return
|
||
* options in the stack, bring up the key list, finish the update code,
|
||
* and finally return with the catched return data
|
||
*/
|
||
|
||
ExceptionRangeTarget(envPtr, range, catchOffset);
|
||
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
|
||
TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
|
||
TclEmitOpcode( INST_END_CATCH, envPtr);
|
||
TclEmitInstInt4( INST_REVERSE, 3, envPtr);
|
||
|
||
TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
|
||
TclEmitInt4( infoIndex, envPtr);
|
||
TclEmitOpcode( INST_RETURN_STK, envPtr);
|
||
|
||
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
|
||
Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
|
||
(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
|
||
}
|
||
TclStackFree(interp, keyTokenPtrs);
|
||
return TCL_OK;
|
||
}
|
||
|
||
int
|
||
TclCompileDictAppendCmd(
|
||
Tcl_Interp *interp, /* Used for looking up stuff. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
Tcl_Token *tokenPtr;
|
||
int i, dictVarIndex;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
/*
|
||
* There must be at least two argument after the command. Since we
|
||
* implement using INST_CONCAT1, make sure the number of arguments
|
||
* stays within its range.
|
||
*/
|
||
|
||
if (parsePtr->numWords<4 || parsePtr->numWords>258) {
|
||
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 TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Produce the string to concatenate onto the dictionary entry.
|
||
*/
|
||
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
for (i=2 ; i<parsePtr->numWords ; i++) {
|
||
CompileWord(envPtr, tokenPtr, interp, i);
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
}
|
||
if (parsePtr->numWords > 4) {
|
||
TclEmitInstInt1(INST_CONCAT1, parsePtr->numWords-3, envPtr);
|
||
}
|
||
|
||
/*
|
||
* Do the concatenation.
|
||
*/
|
||
|
||
TclEmitInstInt4(INST_DICT_APPEND, dictVarIndex, envPtr);
|
||
return TCL_OK;
|
||
}
|
||
|
||
int
|
||
TclCompileDictLappendCmd(
|
||
Tcl_Interp *interp, /* Used for looking up stuff. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
Tcl_Token *varTokenPtr, *keyTokenPtr, *valueTokenPtr;
|
||
int dictVarIndex;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
/*
|
||
* There must be three arguments after the command.
|
||
*/
|
||
|
||
if (parsePtr->numWords != 4) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
keyTokenPtr = TokenAfter(varTokenPtr);
|
||
valueTokenPtr = TokenAfter(keyTokenPtr);
|
||
dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr);
|
||
if (dictVarIndex < 0) {
|
||
return TCL_ERROR;
|
||
}
|
||
CompileWord(envPtr, keyTokenPtr, interp, 2);
|
||
CompileWord(envPtr, valueTokenPtr, interp, 3);
|
||
TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* DupDictUpdateInfo, FreeDictUpdateInfo --
|
||
*
|
||
* Functions to duplicate, release and print the aux data created for use
|
||
* with the INST_DICT_UPDATE_START and INST_DICT_UPDATE_END instructions.
|
||
*
|
||
* Results:
|
||
* DupDictUpdateInfo: a copy of the auxiliary data
|
||
* FreeDictUpdateInfo: none
|
||
* PrintDictUpdateInfo: none
|
||
*
|
||
* Side effects:
|
||
* DupDictUpdateInfo: allocates memory
|
||
* FreeDictUpdateInfo: releases memory
|
||
* PrintDictUpdateInfo: none
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static ClientData
|
||
DupDictUpdateInfo(
|
||
ClientData clientData)
|
||
{
|
||
DictUpdateInfo *dui1Ptr, *dui2Ptr;
|
||
unsigned len;
|
||
|
||
dui1Ptr = clientData;
|
||
len = sizeof(DictUpdateInfo) + sizeof(int) * (dui1Ptr->length - 1);
|
||
dui2Ptr = (DictUpdateInfo *) ckalloc(len);
|
||
memcpy(dui2Ptr, dui1Ptr, len);
|
||
return dui2Ptr;
|
||
}
|
||
|
||
static void
|
||
FreeDictUpdateInfo(
|
||
ClientData clientData)
|
||
{
|
||
ckfree(clientData);
|
||
}
|
||
|
||
static void
|
||
PrintDictUpdateInfo(
|
||
ClientData clientData,
|
||
Tcl_Obj *appendObj,
|
||
ByteCode *codePtr,
|
||
unsigned int pcOffset)
|
||
{
|
||
DictUpdateInfo *duiPtr = clientData;
|
||
int i;
|
||
|
||
for (i=0 ; i<duiPtr->length ; i++) {
|
||
if (i) {
|
||
Tcl_AppendToObj(appendObj, ", ", -1);
|
||
}
|
||
Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]);
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileExprCmd --
|
||
*
|
||
* Procedure called to compile the "expr" command.
|
||
*
|
||
* Results:
|
||
* 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. */
|
||
{
|
||
Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;
|
||
JumpFixup jumpEvalCondFixup;
|
||
int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist;
|
||
int bodyRange, nextRange;
|
||
int savedStackDepth = envPtr->currStackDepth;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
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;
|
||
}
|
||
|
||
/*
|
||
* Create ExceptionRange records for the body and the "next" command. The
|
||
* "next" command's ExceptionRange supports break but not continue (and
|
||
* has a -1 continueOffset).
|
||
*/
|
||
|
||
bodyRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
|
||
nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
|
||
|
||
/*
|
||
* Inline compile the initial command.
|
||
*/
|
||
|
||
SetLineInformation (1);
|
||
CompileBody(envPtr, startTokenPtr, interp);
|
||
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.
|
||
*/
|
||
|
||
bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange);
|
||
SetLineInformation (4);
|
||
CompileBody(envPtr, bodyTokenPtr, interp);
|
||
ExceptionRangeEnds(envPtr, bodyRange);
|
||
envPtr->currStackDepth = savedStackDepth + 1;
|
||
TclEmitOpcode(INST_POP, envPtr);
|
||
|
||
/*
|
||
* Compile the "next" subcommand.
|
||
*/
|
||
|
||
envPtr->currStackDepth = savedStackDepth;
|
||
nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange);
|
||
SetLineInformation (3);
|
||
CompileBody(envPtr, nextTokenPtr, interp);
|
||
ExceptionRangeEnds(envPtr, nextRange);
|
||
envPtr->currStackDepth = savedStackDepth + 1;
|
||
TclEmitOpcode(INST_POP, envPtr);
|
||
envPtr->currStackDepth = savedStackDepth;
|
||
|
||
/*
|
||
* Compile the test expression then emit the conditional jump that
|
||
* terminates the for.
|
||
*/
|
||
|
||
testCodeOffset = CurrentOffset(envPtr);
|
||
|
||
jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
|
||
if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
|
||
bodyCodeOffset += 3;
|
||
nextCodeOffset += 3;
|
||
testCodeOffset += 3;
|
||
}
|
||
|
||
SetLineInformation (2);
|
||
envPtr->currStackDepth = savedStackDepth;
|
||
TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
|
||
envPtr->currStackDepth = savedStackDepth + 1;
|
||
|
||
jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
|
||
if (jumpDist > 127) {
|
||
TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
|
||
} else {
|
||
TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
|
||
}
|
||
|
||
/*
|
||
* 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);
|
||
|
||
/*
|
||
* The for command's result is an empty string.
|
||
*/
|
||
|
||
envPtr->currStackDepth = savedStackDepth;
|
||
PushLiteral(envPtr, "", 0);
|
||
|
||
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. */
|
||
{
|
||
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;
|
||
unsigned char *jumpPc;
|
||
JumpFixup jumpFalseFixup;
|
||
int jumpBackDist, jumpBackOffset, infoIndex, range;
|
||
int numWords, numLists, tempVar, i, j, code = TCL_OK;
|
||
int savedStackDepth = envPtr->currStackDepth;
|
||
Tcl_Obj *varListObj = NULL;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
/*
|
||
* 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 = (ForeachInfo *) ckalloc((unsigned)
|
||
sizeof(ForeachInfo) + 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 = (ForeachVarList *) ckalloc((unsigned)
|
||
sizeof(ForeachVarList) + numVars*sizeof(int));
|
||
varListPtr->numVars = numVars;
|
||
infoPtr->varLists[i/2] = varListPtr;
|
||
infoPtr->numLists++;
|
||
|
||
for (j = 0; j < numVars; j++) {
|
||
Tcl_Obj *varNameObj;
|
||
int numBytes;
|
||
const char *bytes;
|
||
|
||
Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj);
|
||
bytes = Tcl_GetStringFromObj(varNameObj, &numBytes);
|
||
varListPtr->varIndexes[j] = LocalScalar(bytes, numBytes, envPtr);
|
||
if (varListPtr->varIndexes[j] < 0) {
|
||
code = TCL_ERROR;
|
||
goto done;
|
||
}
|
||
}
|
||
Tcl_SetObjLength(varListObj, 0);
|
||
}
|
||
|
||
/*
|
||
* Reserve (numLists + 1) temporary variables:
|
||
* - numLists temps to hold each value list
|
||
* - 1 temp for the loop counter (index of next element in each list)
|
||
*
|
||
* At this time we don't try to reuse temporaries; if there are two
|
||
* nonoverlapping foreach loops, they don't share any temps.
|
||
*/
|
||
|
||
tempVar = TclFindCompiledLocal(NULL, 0, 1, procPtr);
|
||
infoPtr->firstValueTemp = tempVar;
|
||
for (i= 1; i < numLists; i++) {
|
||
TclFindCompiledLocal(NULL, 0, 1, procPtr);
|
||
}
|
||
infoPtr->loopCtTemp = TclFindCompiledLocal(NULL, 0, 1, procPtr);
|
||
|
||
infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr);
|
||
|
||
/*
|
||
* Create an exception record to handle [break] and [continue].
|
||
*/
|
||
|
||
range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
|
||
|
||
/*
|
||
* Evaluate then store each value list in the associated temporary.
|
||
*/
|
||
|
||
for (i = 0, tokenPtr = parsePtr->tokenPtr;
|
||
i < numWords-1;
|
||
i++, tokenPtr = TokenAfter(tokenPtr)) {
|
||
if ((i%2 == 0) && (i > 0)) {
|
||
SetLineInformation (i);
|
||
CompileTokens(envPtr, tokenPtr, interp);
|
||
if (tempVar <= 255) {
|
||
TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr);
|
||
} else {
|
||
TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr);
|
||
}
|
||
TclEmitOpcode(INST_POP, envPtr);
|
||
tempVar++;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Initialize the temporary var that holds the count of loop iterations.
|
||
*/
|
||
|
||
TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);
|
||
|
||
/*
|
||
* Top of loop code: assign each loop variable and check whether
|
||
* to terminate the loop.
|
||
*/
|
||
|
||
ExceptionRangeTarget(envPtr, range, continueOffset);
|
||
TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
|
||
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
|
||
|
||
/*
|
||
* Inline compile the loop body.
|
||
*/
|
||
|
||
SetLineInformation (numWords - 1);
|
||
ExceptionRangeStarts(envPtr, range);
|
||
CompileBody(envPtr, bodyTokenPtr, interp);
|
||
ExceptionRangeEnds(envPtr, range);
|
||
envPtr->currStackDepth = savedStackDepth + 1;
|
||
TclEmitOpcode(INST_POP, envPtr);
|
||
|
||
/*
|
||
* Jump back to the test at the top of the loop. Generate a 4 byte jump if
|
||
* the distance to the test is > 120 bytes. This is conservative and
|
||
* ensures that we won't have to replace this jump if we later need to
|
||
* replace the ifFalse jump with a 4 byte jump.
|
||
*/
|
||
|
||
jumpBackOffset = CurrentOffset(envPtr);
|
||
jumpBackDist = jumpBackOffset-envPtr->exceptArrayPtr[range].continueOffset;
|
||
if (jumpBackDist > 120) {
|
||
TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr);
|
||
} else {
|
||
TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr);
|
||
}
|
||
|
||
/*
|
||
* Fix the target of the jump after the foreach_step test.
|
||
*/
|
||
|
||
if (TclFixupForwardJumpToHere(envPtr, &jumpFalseFixup, 127)) {
|
||
/*
|
||
* Update the loop body's starting PC offset since it moved down.
|
||
*/
|
||
|
||
envPtr->exceptArrayPtr[range].codeOffset += 3;
|
||
|
||
/*
|
||
* Update the jump back to the test at the top of the loop since it
|
||
* also moved down 3 bytes.
|
||
*/
|
||
|
||
jumpBackOffset += 3;
|
||
jumpPc = (envPtr->codeStart + jumpBackOffset);
|
||
jumpBackDist += 3;
|
||
if (jumpBackDist > 120) {
|
||
TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc);
|
||
} else {
|
||
TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc);
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Set the loop's break target.
|
||
*/
|
||
|
||
ExceptionRangeTarget(envPtr, range, breakOffset);
|
||
|
||
/*
|
||
* The foreach command's result is an empty string.
|
||
*/
|
||
|
||
envPtr->currStackDepth = savedStackDepth;
|
||
PushLiteral(envPtr, "", 0);
|
||
envPtr->currStackDepth = savedStackDepth + 1;
|
||
|
||
done:
|
||
if (code == TCL_ERROR) {
|
||
if (infoPtr) {
|
||
FreeForeachInfo(infoPtr);
|
||
}
|
||
}
|
||
if (varListObj) {
|
||
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. */
|
||
{
|
||
register ForeachInfo *srcPtr = clientData;
|
||
ForeachInfo *dupPtr;
|
||
register ForeachVarList *srcListPtr, *dupListPtr;
|
||
int numVars, i, j, numLists = srcPtr->numLists;
|
||
|
||
dupPtr = (ForeachInfo *) ckalloc((unsigned)
|
||
sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *));
|
||
dupPtr->numLists = numLists;
|
||
dupPtr->firstValueTemp = srcPtr->firstValueTemp;
|
||
dupPtr->loopCtTemp = srcPtr->loopCtTemp;
|
||
|
||
for (i = 0; i < numLists; i++) {
|
||
srcListPtr = srcPtr->varLists[i];
|
||
numVars = srcListPtr->numVars;
|
||
dupListPtr = (ForeachVarList *) ckalloc((unsigned)
|
||
sizeof(ForeachVarList) + numVars*sizeof(int));
|
||
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. */
|
||
{
|
||
register ForeachInfo *infoPtr = clientData;
|
||
register ForeachVarList *listPtr;
|
||
int numLists = infoPtr->numLists;
|
||
register int i;
|
||
|
||
for (i = 0; i < numLists; i++) {
|
||
listPtr = infoPtr->varLists[i];
|
||
ckfree((char *) listPtr);
|
||
}
|
||
ckfree((char *) infoPtr);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* PrintForeachInfo --
|
||
*
|
||
* Function to write a human-readable representation of a ForeachInfo
|
||
* structure to stdout for debugging.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static void
|
||
PrintForeachInfo(
|
||
ClientData clientData,
|
||
Tcl_Obj *appendObj,
|
||
ByteCode *codePtr,
|
||
unsigned int pcOffset)
|
||
{
|
||
register ForeachInfo *infoPtr = clientData;
|
||
register ForeachVarList *varsPtr;
|
||
int i, j;
|
||
|
||
Tcl_AppendToObj(appendObj, "data=[", -1);
|
||
|
||
for (i=0 ; i<infoPtr->numLists ; i++) {
|
||
if (i) {
|
||
Tcl_AppendToObj(appendObj, ", ", -1);
|
||
}
|
||
Tcl_AppendPrintfToObj(appendObj, "%%v%u",
|
||
(unsigned) (infoPtr->firstValueTemp + i));
|
||
}
|
||
Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%u",
|
||
(unsigned) infoPtr->loopCtTemp);
|
||
for (i=0 ; i<infoPtr->numLists ; i++) {
|
||
if (i) {
|
||
Tcl_AppendToObj(appendObj, ",", -1);
|
||
}
|
||
Tcl_AppendPrintfToObj(appendObj, "\n\t\t it%%v%u\t[",
|
||
(unsigned) (infoPtr->firstValueTemp + i));
|
||
varsPtr = infoPtr->varLists[i];
|
||
for (j=0 ; j<varsPtr->numVars ; j++) {
|
||
if (j) {
|
||
Tcl_AppendToObj(appendObj, ", ", -1);
|
||
}
|
||
Tcl_AppendPrintfToObj(appendObj, "%%v%u",
|
||
(unsigned) varsPtr->varIndexes[j]);
|
||
}
|
||
Tcl_AppendToObj(appendObj, "]", -1);
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileIfCmd --
|
||
*
|
||
* Procedure called to compile the "if" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "if" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileIfCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
JumpFixupArray jumpFalseFixupArray;
|
||
/* Used to fix the ifFalse jump after each
|
||
* test when its target PC is determined. */
|
||
JumpFixupArray jumpEndFixupArray;
|
||
/* Used to fix the jump after each "then" body
|
||
* to the end of the "if" when that PC is
|
||
* determined. */
|
||
Tcl_Token *tokenPtr, *testTokenPtr;
|
||
int jumpIndex = 0; /* Avoid compiler warning. */
|
||
int jumpFalseDist, numWords, wordIdx, numBytes, j, code;
|
||
const char *word;
|
||
int savedStackDepth = envPtr->currStackDepth;
|
||
/* Saved stack depth at the start of the first
|
||
* test; the envPtr current depth is restored
|
||
* to this value at the start of each test. */
|
||
int realCond = 1; /* Set to 0 for static conditions:
|
||
* "if 0 {..}" */
|
||
int boolVal; /* Value of static condition. */
|
||
int compileScripts = 1;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
/*
|
||
* Only compile the "if" command if all arguments are simple words, in
|
||
* order to insure correct substitution [Bug 219166]
|
||
*/
|
||
|
||
tokenPtr = parsePtr->tokenPtr;
|
||
wordIdx = 0;
|
||
numWords = parsePtr->numWords;
|
||
|
||
for (wordIdx = 0; wordIdx < numWords; wordIdx++) {
|
||
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
|
||
return TCL_ERROR;
|
||
}
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
}
|
||
|
||
TclInitJumpFixupArray(&jumpFalseFixupArray);
|
||
TclInitJumpFixupArray(&jumpEndFixupArray);
|
||
code = TCL_OK;
|
||
|
||
/*
|
||
* Each iteration of this loop compiles one "if expr ?then? body" or
|
||
* "elseif expr ?then? body" clause.
|
||
*/
|
||
|
||
tokenPtr = parsePtr->tokenPtr;
|
||
wordIdx = 0;
|
||
while (wordIdx < numWords) {
|
||
/*
|
||
* Stop looping if the token isn't "if" or "elseif".
|
||
*/
|
||
|
||
word = tokenPtr[1].start;
|
||
numBytes = tokenPtr[1].size;
|
||
if ((tokenPtr == parsePtr->tokenPtr)
|
||
|| ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) {
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
wordIdx++;
|
||
} else {
|
||
break;
|
||
}
|
||
if (wordIdx >= numWords) {
|
||
code = TCL_ERROR;
|
||
goto done;
|
||
}
|
||
|
||
/*
|
||
* Compile the test expression then emit the conditional jump around
|
||
* the "then" part.
|
||
*/
|
||
|
||
envPtr->currStackDepth = savedStackDepth;
|
||
testTokenPtr = tokenPtr;
|
||
|
||
if (realCond) {
|
||
/*
|
||
* Find out if the condition is a constant.
|
||
*/
|
||
|
||
Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start,
|
||
testTokenPtr[1].size);
|
||
Tcl_IncrRefCount(boolObj);
|
||
code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
|
||
TclDecrRefCount(boolObj);
|
||
if (code == TCL_OK) {
|
||
/*
|
||
* A static condition.
|
||
*/
|
||
|
||
realCond = 0;
|
||
if (!boolVal) {
|
||
compileScripts = 0;
|
||
}
|
||
} else {
|
||
SetLineInformation (wordIdx);
|
||
Tcl_ResetResult(interp);
|
||
TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
|
||
if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
|
||
TclExpandJumpFixupArray(&jumpFalseFixupArray);
|
||
}
|
||
jumpIndex = jumpFalseFixupArray.next;
|
||
jumpFalseFixupArray.next++;
|
||
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
|
||
jumpFalseFixupArray.fixup+jumpIndex);
|
||
}
|
||
code = TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* Skip over the optional "then" before the then clause.
|
||
*/
|
||
|
||
tokenPtr = TokenAfter(testTokenPtr);
|
||
wordIdx++;
|
||
if (wordIdx >= numWords) {
|
||
code = TCL_ERROR;
|
||
goto done;
|
||
}
|
||
if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
|
||
word = tokenPtr[1].start;
|
||
numBytes = tokenPtr[1].size;
|
||
if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) {
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
wordIdx++;
|
||
if (wordIdx >= numWords) {
|
||
code = TCL_ERROR;
|
||
goto done;
|
||
}
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Compile the "then" command body.
|
||
*/
|
||
|
||
if (compileScripts) {
|
||
SetLineInformation (wordIdx);
|
||
envPtr->currStackDepth = savedStackDepth;
|
||
CompileBody(envPtr, tokenPtr, interp);
|
||
}
|
||
|
||
if (realCond) {
|
||
/*
|
||
* Jump to the end of the "if" command. Both jumpFalseFixupArray
|
||
* and jumpEndFixupArray are indexed by "jumpIndex".
|
||
*/
|
||
|
||
if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {
|
||
TclExpandJumpFixupArray(&jumpEndFixupArray);
|
||
}
|
||
jumpEndFixupArray.next++;
|
||
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
|
||
jumpEndFixupArray.fixup+jumpIndex);
|
||
|
||
/*
|
||
* Fix the target of the jumpFalse after the test. Generate a 4
|
||
* byte jump if the distance is > 120 bytes. This is conservative,
|
||
* and ensures that we won't have to replace this jump if we later
|
||
* also need to replace the proceeding jump to the end of the "if"
|
||
* with a 4 byte jump.
|
||
*/
|
||
|
||
if (TclFixupForwardJumpToHere(envPtr,
|
||
jumpFalseFixupArray.fixup+jumpIndex, 120)) {
|
||
/*
|
||
* Adjust the code offset for the proceeding jump to the end
|
||
* of the "if" command.
|
||
*/
|
||
|
||
jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
|
||
}
|
||
} else if (boolVal) {
|
||
/*
|
||
* We were processing an "if 1 {...}"; stop compiling scripts.
|
||
*/
|
||
|
||
compileScripts = 0;
|
||
} else {
|
||
/*
|
||
* We were processing an "if 0 {...}"; reset so that the rest
|
||
* (elseif, else) is compiled correctly.
|
||
*/
|
||
|
||
realCond = 1;
|
||
compileScripts = 1;
|
||
}
|
||
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
wordIdx++;
|
||
}
|
||
|
||
/*
|
||
* Restore the current stack depth in the environment; the "else" clause
|
||
* (or its default) will add 1 to this.
|
||
*/
|
||
|
||
envPtr->currStackDepth = savedStackDepth;
|
||
|
||
/*
|
||
* Check for the optional else clause. Do not compile anything if this was
|
||
* an "if 1 {...}" case.
|
||
*/
|
||
|
||
if ((wordIdx < numWords) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
|
||
/*
|
||
* There is an else clause. Skip over the optional "else" word.
|
||
*/
|
||
|
||
word = tokenPtr[1].start;
|
||
numBytes = tokenPtr[1].size;
|
||
if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) {
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
wordIdx++;
|
||
if (wordIdx >= numWords) {
|
||
code = TCL_ERROR;
|
||
goto done;
|
||
}
|
||
}
|
||
|
||
if (compileScripts) {
|
||
/*
|
||
* Compile the else command body.
|
||
*/
|
||
|
||
SetLineInformation (wordIdx);
|
||
CompileBody(envPtr, tokenPtr, interp);
|
||
}
|
||
|
||
/*
|
||
* Make sure there are no words after the else clause.
|
||
*/
|
||
|
||
wordIdx++;
|
||
if (wordIdx < numWords) {
|
||
code = TCL_ERROR;
|
||
goto done;
|
||
}
|
||
} else {
|
||
/*
|
||
* No else clause: the "if" command's result is an empty string.
|
||
*/
|
||
|
||
if (compileScripts) {
|
||
PushLiteral(envPtr, "", 0);
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Fix the unconditional jumps to the end of the "if" command.
|
||
*/
|
||
|
||
for (j = jumpEndFixupArray.next; j > 0; j--) {
|
||
jumpIndex = (j - 1); /* i.e. process the closest jump first. */
|
||
if (TclFixupForwardJumpToHere(envPtr,
|
||
jumpEndFixupArray.fixup+jumpIndex, 127)) {
|
||
/*
|
||
* Adjust the immediately preceeding "ifFalse" jump. We moved it's
|
||
* target (just after this jump) down three bytes.
|
||
*/
|
||
|
||
unsigned char *ifFalsePc = envPtr->codeStart
|
||
+ jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
|
||
unsigned char opCode = *ifFalsePc;
|
||
|
||
if (opCode == INST_JUMP_FALSE1) {
|
||
jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1);
|
||
jumpFalseDist += 3;
|
||
TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
|
||
} else if (opCode == INST_JUMP_FALSE4) {
|
||
jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
|
||
jumpFalseDist += 3;
|
||
TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
|
||
} else {
|
||
Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode);
|
||
}
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Free the jumpFixupArray array if malloc'ed storage was used.
|
||
*/
|
||
|
||
done:
|
||
envPtr->currStackDepth = savedStackDepth + 1;
|
||
TclFreeJumpFixupArray(&jumpFalseFixupArray);
|
||
TclFreeJumpFixupArray(&jumpEndFixupArray);
|
||
return code;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileIncrCmd --
|
||
*
|
||
* Procedure called to compile the "incr" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "incr" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileIncrCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
Tcl_Token *varTokenPtr, *incrTokenPtr;
|
||
int simpleVarName, isScalar, localIndex, haveImmValue, immValue;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
|
||
PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX|TCL_CREATE_VAR,
|
||
&localIndex, &simpleVarName, &isScalar, 1);
|
||
|
||
/*
|
||
* If an increment is given, push it, but see first if it's a small
|
||
* integer.
|
||
*/
|
||
|
||
haveImmValue = 0;
|
||
immValue = 1;
|
||
if (parsePtr->numWords == 3) {
|
||
incrTokenPtr = TokenAfter(varTokenPtr);
|
||
if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
|
||
const char *word = incrTokenPtr[1].start;
|
||
int numBytes = incrTokenPtr[1].size;
|
||
int code;
|
||
Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes);
|
||
Tcl_IncrRefCount(intObj);
|
||
code = TclGetIntFromObj(NULL, intObj, &immValue);
|
||
TclDecrRefCount(intObj);
|
||
if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) {
|
||
haveImmValue = 1;
|
||
}
|
||
if (!haveImmValue) {
|
||
PushLiteral(envPtr, word, numBytes);
|
||
}
|
||
} else {
|
||
SetLineInformation (2);
|
||
CompileTokens(envPtr, incrTokenPtr, interp);
|
||
}
|
||
} else { /* No incr amount given so use 1. */
|
||
haveImmValue = 1;
|
||
}
|
||
|
||
/*
|
||
* Emit the instruction to increment the variable.
|
||
*/
|
||
|
||
if (simpleVarName) {
|
||
if (isScalar) {
|
||
if (localIndex >= 0) {
|
||
if (haveImmValue) {
|
||
TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr);
|
||
TclEmitInt1(immValue, envPtr);
|
||
} else {
|
||
TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr);
|
||
}
|
||
} else {
|
||
if (haveImmValue) {
|
||
TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr);
|
||
} else {
|
||
TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr);
|
||
}
|
||
}
|
||
} else {
|
||
if (localIndex >= 0) {
|
||
if (haveImmValue) {
|
||
TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr);
|
||
TclEmitInt1(immValue, envPtr);
|
||
} else {
|
||
TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr);
|
||
}
|
||
} else {
|
||
if (haveImmValue) {
|
||
TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr);
|
||
} else {
|
||
TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr);
|
||
}
|
||
}
|
||
}
|
||
} else { /* Non-simple variable name. */
|
||
if (haveImmValue) {
|
||
TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr);
|
||
} else {
|
||
TclEmitOpcode(INST_INCR_STK, envPtr);
|
||
}
|
||
}
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileLappendCmd --
|
||
*
|
||
* Procedure called to compile the "lappend" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "lappend" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileLappendCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
Tcl_Token *varTokenPtr;
|
||
int simpleVarName, isScalar, localIndex, numWords;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
/*
|
||
* If we're not in a procedure, don't compile.
|
||
*/
|
||
|
||
if (envPtr->procPtr == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
numWords = parsePtr->numWords;
|
||
if (numWords == 1) {
|
||
return TCL_ERROR;
|
||
}
|
||
if (numWords != 3) {
|
||
/*
|
||
* LAPPEND instructions currently only handle one value appends.
|
||
*/
|
||
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Decide if we can use a frame slot for the var/array name or if we
|
||
* need to emit code to compute and push the name at runtime. We use a
|
||
* frame slot (entry in the array of local vars) if we are compiling a
|
||
* procedure body and if the name is simple text that does not include
|
||
* namespace qualifiers.
|
||
*/
|
||
|
||
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
|
||
PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
|
||
&localIndex, &simpleVarName, &isScalar, 1);
|
||
|
||
/*
|
||
* If we are doing an assignment, push the new value. In the no values
|
||
* case, create an empty object.
|
||
*/
|
||
|
||
if (numWords > 2) {
|
||
Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr);
|
||
CompileWord(envPtr, valueTokenPtr, interp, 2);
|
||
}
|
||
|
||
/*
|
||
* Emit instructions to set/get the variable.
|
||
*/
|
||
|
||
/*
|
||
* The *_STK opcodes should be refactored to make better use of existing
|
||
* LOAD/STORE instructions.
|
||
*/
|
||
|
||
if (simpleVarName) {
|
||
if (isScalar) {
|
||
if (localIndex < 0) {
|
||
TclEmitOpcode(INST_LAPPEND_STK, envPtr);
|
||
} else if (localIndex <= 255) {
|
||
TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr);
|
||
} else {
|
||
TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr);
|
||
}
|
||
} else {
|
||
if (localIndex < 0) {
|
||
TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr);
|
||
} else if (localIndex <= 255) {
|
||
TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr);
|
||
} else {
|
||
TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr);
|
||
}
|
||
}
|
||
} else {
|
||
TclEmitOpcode(INST_LAPPEND_STK, envPtr);
|
||
}
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileLassignCmd --
|
||
*
|
||
* Procedure called to compile the "lassign" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "lassign" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileLassignCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
Tcl_Token *tokenPtr;
|
||
int simpleVarName, isScalar, localIndex, numWords, idx;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
numWords = parsePtr->numWords;
|
||
|
||
/*
|
||
* Check for command syntax error, but we'll punt that to runtime.
|
||
*/
|
||
|
||
if (numWords < 3) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Generate code to push list being taken apart by [lassign].
|
||
*/
|
||
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, 1);
|
||
|
||
/*
|
||
* Generate code to assign values from the list to variables.
|
||
*/
|
||
|
||
for (idx=0 ; idx<numWords-2 ; idx++) {
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
|
||
/*
|
||
* Generate the next variable name.
|
||
*/
|
||
|
||
PushVarNameWord(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex,
|
||
&simpleVarName, &isScalar, idx+2);
|
||
|
||
/*
|
||
* Emit instructions to get the idx'th item out of the list value on
|
||
* the stack and assign it to the variable.
|
||
*/
|
||
|
||
if (simpleVarName) {
|
||
if (isScalar) {
|
||
if (localIndex >= 0) {
|
||
TclEmitOpcode(INST_DUP, envPtr);
|
||
TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
|
||
if (localIndex <= 255) {
|
||
TclEmitInstInt1(INST_STORE_SCALAR1,localIndex,envPtr);
|
||
} else {
|
||
TclEmitInstInt4(INST_STORE_SCALAR4,localIndex,envPtr);
|
||
}
|
||
} else {
|
||
TclEmitInstInt4(INST_OVER, 1, envPtr);
|
||
TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
|
||
TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr);
|
||
}
|
||
} else {
|
||
if (localIndex >= 0) {
|
||
TclEmitInstInt4(INST_OVER, 1, envPtr);
|
||
TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
|
||
if (localIndex <= 255) {
|
||
TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr);
|
||
} else {
|
||
TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr);
|
||
}
|
||
} else {
|
||
TclEmitInstInt4(INST_OVER, 2, envPtr);
|
||
TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
|
||
TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr);
|
||
}
|
||
}
|
||
} else {
|
||
TclEmitInstInt4(INST_OVER, 1, envPtr);
|
||
TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
|
||
TclEmitOpcode(INST_STORE_STK, envPtr);
|
||
}
|
||
TclEmitOpcode(INST_POP, envPtr);
|
||
}
|
||
|
||
/*
|
||
* Generate code to leave the rest of the list on the stack.
|
||
*/
|
||
|
||
TclEmitInstInt4(INST_LIST_RANGE_IMM, idx, envPtr);
|
||
TclEmitInt4(-2, envPtr); /* -2 == "end" */
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileLindexCmd --
|
||
*
|
||
* Procedure called to compile the "lindex" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "lindex" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileLindexCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
Tcl_Token *idxTokenPtr, *valTokenPtr;
|
||
int i, numWords = parsePtr->numWords;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
/*
|
||
* Quit if too few args.
|
||
*/
|
||
|
||
if (numWords <= 1) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
valTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
if (numWords != 3) {
|
||
goto emitComplexLindex;
|
||
}
|
||
|
||
idxTokenPtr = TokenAfter(valTokenPtr);
|
||
if (idxTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
|
||
Tcl_Obj *tmpObj;
|
||
int idx, result;
|
||
|
||
tmpObj = Tcl_NewStringObj(idxTokenPtr[1].start, idxTokenPtr[1].size);
|
||
result = TclGetIntFromObj(NULL, tmpObj, &idx);
|
||
TclDecrRefCount(tmpObj);
|
||
|
||
if (result == TCL_OK && idx >= 0) {
|
||
/*
|
||
* All checks have been completed, and we have exactly this
|
||
* construct:
|
||
* lindex <arbitraryValue> <posInt>
|
||
* This is best compiled as a push of the arbitrary value followed
|
||
* by an "immediate lindex" which is the most efficient variety.
|
||
*/
|
||
|
||
CompileWord(envPtr, valTokenPtr, interp, 1);
|
||
TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* If the conversion failed or the value was negative, we just keep on
|
||
* going with the more complex compilation.
|
||
*/
|
||
}
|
||
|
||
/*
|
||
* Push the operands onto the stack.
|
||
*/
|
||
|
||
emitComplexLindex:
|
||
for (i=1 ; i<numWords ; i++) {
|
||
CompileWord(envPtr, valTokenPtr, interp, i);
|
||
valTokenPtr = TokenAfter(valTokenPtr);
|
||
}
|
||
|
||
/*
|
||
* Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI if there are
|
||
* multiple index args.
|
||
*/
|
||
|
||
if (numWords == 3) {
|
||
TclEmitOpcode(INST_LIST_INDEX, envPtr);
|
||
} else {
|
||
TclEmitInstInt4(INST_LIST_INDEX_MULTI, numWords-1, envPtr);
|
||
}
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileListCmd --
|
||
*
|
||
* Procedure called to compile the "list" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "list" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileListCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
/*
|
||
* If we're not in a procedure, don't compile.
|
||
*/
|
||
|
||
if (envPtr->procPtr == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (parsePtr->numWords == 1) {
|
||
/*
|
||
* [list] without arguments just pushes an empty object.
|
||
*/
|
||
|
||
PushLiteral(envPtr, "", 0);
|
||
} else {
|
||
/*
|
||
* Push the all values onto the stack.
|
||
*/
|
||
|
||
Tcl_Token *valueTokenPtr;
|
||
int i, numWords;
|
||
|
||
numWords = parsePtr->numWords;
|
||
|
||
valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
for (i = 1; i < numWords; i++) {
|
||
CompileWord(envPtr, valueTokenPtr, interp, i);
|
||
valueTokenPtr = TokenAfter(valueTokenPtr);
|
||
}
|
||
TclEmitInstInt4(INST_LIST, numWords - 1, envPtr);
|
||
}
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileLlengthCmd --
|
||
*
|
||
* Procedure called to compile the "llength" 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 "llength" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileLlengthCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
Tcl_Token *varTokenPtr;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
if (parsePtr->numWords != 2) {
|
||
return TCL_ERROR;
|
||
}
|
||
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
|
||
CompileWord(envPtr, varTokenPtr, interp, 1);
|
||
TclEmitOpcode(INST_LIST_LENGTH, envPtr);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileLsetCmd --
|
||
*
|
||
* Procedure called to compile the "lset" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "lset" command at
|
||
* runtime.
|
||
*
|
||
* The general template for execution of the "lset" command is:
|
||
* (1) Instructions to push the variable name, unless the variable is
|
||
* local to the stack frame.
|
||
* (2) If the variable is an array element, instructions to push the
|
||
* array element name.
|
||
* (3) Instructions to push each of zero or more "index" arguments to the
|
||
* stack, followed with the "newValue" element.
|
||
* (4) Instructions to duplicate the variable name and/or array element
|
||
* name onto the top of the stack, if either was pushed at steps (1)
|
||
* and (2).
|
||
* (5) The appropriate INST_LOAD_* instruction to place the original
|
||
* value of the list variable at top of stack.
|
||
* (6) At this point, the stack contains:
|
||
* varName? arrayElementName? index1 index2 ... newValue oldList
|
||
* The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST
|
||
* according as whether there is exactly one index element (LIST) or
|
||
* either zero or else two or more (FLAT). This instruction removes
|
||
* everything from the stack except for the two names and pushes the
|
||
* new value of the variable.
|
||
* (7) Finally, INST_STORE_* stores the new value in the variable and
|
||
* cleans up the stack.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileLsetCmd(
|
||
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the
|
||
* command. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds the resulting instructions. */
|
||
{
|
||
int tempDepth; /* Depth used for emitting one part of the
|
||
* code burst. */
|
||
Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
|
||
* parse of the variable name. */
|
||
int localIndex; /* Index of var in local var table. */
|
||
int simpleVarName; /* Flag == 1 if var name is simple. */
|
||
int isScalar; /* Flag == 1 if scalar, 0 if array. */
|
||
int i;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
/*
|
||
* Check argument count.
|
||
*/
|
||
|
||
if (parsePtr->numWords < 3) {
|
||
/*
|
||
* Fail at run time, not in compilation.
|
||
*/
|
||
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Decide if we can use a frame slot for the var/array name or if we need
|
||
* to emit code to compute and push the name at runtime. We use a frame
|
||
* slot (entry in the array of local vars) if we are compiling a procedure
|
||
* body and if the name is simple text that does not include namespace
|
||
* qualifiers.
|
||
*/
|
||
|
||
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
|
||
&localIndex, &simpleVarName, &isScalar, 1);
|
||
|
||
/*
|
||
* Push the "index" args and the new element value.
|
||
*/
|
||
|
||
for (i=2 ; i<parsePtr->numWords ; ++i) {
|
||
varTokenPtr = TokenAfter(varTokenPtr);
|
||
CompileWord(envPtr, varTokenPtr, interp, i);
|
||
}
|
||
|
||
/*
|
||
* Duplicate the variable name if it's been pushed.
|
||
*/
|
||
|
||
if (!simpleVarName || localIndex < 0) {
|
||
if (!simpleVarName || isScalar) {
|
||
tempDepth = parsePtr->numWords - 2;
|
||
} else {
|
||
tempDepth = parsePtr->numWords - 1;
|
||
}
|
||
TclEmitInstInt4(INST_OVER, tempDepth, envPtr);
|
||
}
|
||
|
||
/*
|
||
* Duplicate an array index if one's been pushed.
|
||
*/
|
||
|
||
if (simpleVarName && !isScalar) {
|
||
if (localIndex < 0) {
|
||
tempDepth = parsePtr->numWords - 1;
|
||
} else {
|
||
tempDepth = parsePtr->numWords - 2;
|
||
}
|
||
TclEmitInstInt4(INST_OVER, tempDepth, envPtr);
|
||
}
|
||
|
||
/*
|
||
* Emit code to load the variable's value.
|
||
*/
|
||
|
||
if (!simpleVarName) {
|
||
TclEmitOpcode(INST_LOAD_STK, envPtr);
|
||
} else if (isScalar) {
|
||
if (localIndex < 0) {
|
||
TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
|
||
} else if (localIndex < 0x100) {
|
||
TclEmitInstInt1(INST_LOAD_SCALAR1, localIndex, envPtr);
|
||
} else {
|
||
TclEmitInstInt4(INST_LOAD_SCALAR4, localIndex, envPtr);
|
||
}
|
||
} else {
|
||
if (localIndex < 0) {
|
||
TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
|
||
} else if (localIndex < 0x100) {
|
||
TclEmitInstInt1(INST_LOAD_ARRAY1, localIndex, envPtr);
|
||
} else {
|
||
TclEmitInstInt4(INST_LOAD_ARRAY4, localIndex, envPtr);
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Emit the correct variety of 'lset' instruction.
|
||
*/
|
||
|
||
if (parsePtr->numWords == 4) {
|
||
TclEmitOpcode(INST_LSET_LIST, envPtr);
|
||
} else {
|
||
TclEmitInstInt4(INST_LSET_FLAT, parsePtr->numWords-1, envPtr);
|
||
}
|
||
|
||
/*
|
||
* Emit code to put the value back in the variable.
|
||
*/
|
||
|
||
if (!simpleVarName) {
|
||
TclEmitOpcode(INST_STORE_STK, envPtr);
|
||
} else if (isScalar) {
|
||
if (localIndex < 0) {
|
||
TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr);
|
||
} else if (localIndex < 0x100) {
|
||
TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
|
||
} else {
|
||
TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
|
||
}
|
||
} else {
|
||
if (localIndex < 0) {
|
||
TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr);
|
||
} else if (localIndex < 0x100) {
|
||
TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr);
|
||
} else {
|
||
TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr);
|
||
}
|
||
}
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileRegexpCmd --
|
||
*
|
||
* Procedure called to compile the "regexp" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "regexp" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileRegexpCmd(
|
||
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the
|
||
* command. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds the resulting instructions. */
|
||
{
|
||
Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
|
||
* parse of the RE or string. */
|
||
int i, len, nocase, exact, sawLast, simple;
|
||
char *str;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
/*
|
||
* We are only interested in compiling simple regexp cases. Currently
|
||
* supported compile cases are:
|
||
* regexp ?-nocase? ?--? staticString $var
|
||
* regexp ?-nocase? ?--? {^staticString$} $var
|
||
*/
|
||
|
||
if (parsePtr->numWords < 3) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
simple = 0;
|
||
nocase = 0;
|
||
sawLast = 0;
|
||
varTokenPtr = parsePtr->tokenPtr;
|
||
|
||
/*
|
||
* We only look for -nocase and -- as options. Everything else gets pushed
|
||
* to runtime execution. This is different than regexp's runtime option
|
||
* handling, but satisfies our stricter needs.
|
||
*/
|
||
|
||
for (i = 1; i < parsePtr->numWords - 2; i++) {
|
||
varTokenPtr = TokenAfter(varTokenPtr);
|
||
if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
|
||
/*
|
||
* Not a simple string, so punt to runtime.
|
||
*/
|
||
|
||
return TCL_ERROR;
|
||
}
|
||
str = (char *) varTokenPtr[1].start;
|
||
len = varTokenPtr[1].size;
|
||
if ((len == 2) && (str[0] == '-') && (str[1] == '-')) {
|
||
sawLast++;
|
||
i++;
|
||
break;
|
||
} else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) {
|
||
nocase = 1;
|
||
} else {
|
||
/*
|
||
* Not an option we recognize.
|
||
*/
|
||
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
|
||
if ((parsePtr->numWords - i) != 2) {
|
||
/*
|
||
* We don't support capturing to variables.
|
||
*/
|
||
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Get the regexp string. If it is not a simple string or can't be
|
||
* converted to a glob pattern, push the word for the INST_REGEXP.
|
||
* Keep changes here in sync with TclCompileSwitchCmd Switch_Regexp.
|
||
*/
|
||
|
||
varTokenPtr = TokenAfter(varTokenPtr);
|
||
|
||
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
|
||
Tcl_DString ds;
|
||
|
||
str = (char *) varTokenPtr[1].start;
|
||
len = varTokenPtr[1].size;
|
||
/*
|
||
* If it has a '-', it could be an incorrectly formed regexp command.
|
||
*/
|
||
|
||
if ((*str == '-') && !sawLast) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (len == 0) {
|
||
/*
|
||
* The semantics of regexp are always match on re == "".
|
||
*/
|
||
|
||
PushLiteral(envPtr, "1", 1);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* Attempt to convert pattern to glob. If successful, push the
|
||
* converted pattern as a literal.
|
||
*/
|
||
|
||
if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact)
|
||
== TCL_OK) {
|
||
simple = 1;
|
||
PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
|
||
Tcl_DStringFree(&ds);
|
||
}
|
||
}
|
||
|
||
if (!simple) {
|
||
CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2);
|
||
}
|
||
|
||
/*
|
||
* Push the string arg.
|
||
*/
|
||
|
||
varTokenPtr = TokenAfter(varTokenPtr);
|
||
CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1);
|
||
|
||
if (simple) {
|
||
if (exact && !nocase) {
|
||
TclEmitOpcode(INST_STR_EQ, envPtr);
|
||
} else {
|
||
TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
|
||
}
|
||
} else {
|
||
/*
|
||
* Pass correct RE compile flags. We use only Int1 (8-bit), but
|
||
* that handles all the flags we want to pass.
|
||
* Don't use TCL_REG_NOSUB as we may have backrefs.
|
||
*/
|
||
int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0);
|
||
TclEmitInstInt1(INST_REGEXP, cflags, envPtr);
|
||
}
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileReturnCmd --
|
||
*
|
||
* Procedure called to compile the "return" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "return" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileReturnCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
/*
|
||
* General syntax: [return ?-option value ...? ?result?]
|
||
* An even number of words means an explicit result argument is present.
|
||
*/
|
||
int level, code, objc, size, status = TCL_OK;
|
||
int numWords = parsePtr->numWords;
|
||
int explicitResult = (0 == (numWords % 2));
|
||
int numOptionWords = numWords - 1 - explicitResult;
|
||
Tcl_Obj *returnOpts, **objv;
|
||
Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
/*
|
||
* Check for special case which can always be compiled:
|
||
* return -options <opts> <msg>
|
||
* Unlike the normal [return] compilation, this version does everything at
|
||
* runtime so it can handle arbitrary words and not just literals. Note
|
||
* that if INST_RETURN_STK wasn't already needed for something else
|
||
* ('finally' clause processing) this piece of code would not be present.
|
||
*/
|
||
|
||
if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD)
|
||
&& (wordTokenPtr[1].size == 8)
|
||
&& (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) {
|
||
Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr);
|
||
Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr);
|
||
|
||
CompileWord(envPtr, optsTokenPtr, interp, 2);
|
||
CompileWord(envPtr, msgTokenPtr, interp, 3);
|
||
TclEmitOpcode(INST_RETURN_STK, envPtr);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* Allocate some working space.
|
||
*/
|
||
|
||
objv = (Tcl_Obj **) TclStackAlloc(interp,
|
||
numOptionWords * sizeof(Tcl_Obj *));
|
||
|
||
/*
|
||
* Scan through the return options. If any are unknown at compile time,
|
||
* there is no value in bytecompiling. Save the option values known in an
|
||
* objv array for merging into a return options dictionary.
|
||
*/
|
||
|
||
for (objc = 0; objc < numOptionWords; objc++) {
|
||
objv[objc] = Tcl_NewObj();
|
||
Tcl_IncrRefCount(objv[objc]);
|
||
if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
|
||
objc++;
|
||
status = TCL_ERROR;
|
||
goto cleanup;
|
||
}
|
||
wordTokenPtr = TokenAfter(wordTokenPtr);
|
||
}
|
||
status = TclMergeReturnOptions(interp, objc, objv,
|
||
&returnOpts, &code, &level);
|
||
cleanup:
|
||
while (--objc >= 0) {
|
||
TclDecrRefCount(objv[objc]);
|
||
}
|
||
TclStackFree(interp, objv);
|
||
if (TCL_ERROR == status) {
|
||
/*
|
||
* Something was bogus in the return options. Clear the error message,
|
||
* and report back to the compiler that this must be interpreted at
|
||
* runtime.
|
||
*/
|
||
|
||
Tcl_ResetResult(interp);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* All options are known at compile time, so we're going to bytecompile.
|
||
* Emit instructions to push the result on the stack.
|
||
*/
|
||
|
||
if (explicitResult) {
|
||
CompileWord(envPtr, wordTokenPtr, interp, numWords-1);
|
||
} else {
|
||
/*
|
||
* No explict result argument, so default result is empty string.
|
||
*/
|
||
|
||
PushLiteral(envPtr, "", 0);
|
||
}
|
||
|
||
/*
|
||
* Check for optimization: When [return] is in a proc, and there's no
|
||
* enclosing [catch], and there are no return options, then the INST_DONE
|
||
* instruction is equivalent, and may be more efficient.
|
||
*/
|
||
|
||
if (numOptionWords == 0 && envPtr->procPtr != NULL) {
|
||
/*
|
||
* We have default return options and we're in a proc ...
|
||
*/
|
||
|
||
int index = envPtr->exceptArrayNext - 1;
|
||
int enclosingCatch = 0;
|
||
|
||
while (index >= 0) {
|
||
ExceptionRange range = envPtr->exceptArrayPtr[index];
|
||
if ((range.type == CATCH_EXCEPTION_RANGE)
|
||
&& (range.catchOffset == -1)) {
|
||
enclosingCatch = 1;
|
||
break;
|
||
}
|
||
index--;
|
||
}
|
||
if (!enclosingCatch) {
|
||
/*
|
||
* ... and there is no enclosing catch. Issue the maximally
|
||
* efficient exit instruction.
|
||
*/
|
||
|
||
Tcl_DecrRefCount(returnOpts);
|
||
TclEmitOpcode(INST_DONE, envPtr);
|
||
return TCL_OK;
|
||
}
|
||
}
|
||
|
||
/* Optimize [return -level 0 $x]. */
|
||
Tcl_DictObjSize(NULL, returnOpts, &size);
|
||
if (size == 0 && level == 0 && code == TCL_OK) {
|
||
Tcl_DecrRefCount(returnOpts);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* Could not use the optimization, so we push the return options dict, and
|
||
* emit the INST_RETURN_IMM instruction with code and level as operands.
|
||
*/
|
||
|
||
CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts);
|
||
return TCL_OK;
|
||
}
|
||
|
||
static void
|
||
CompileReturnInternal(
|
||
CompileEnv *envPtr,
|
||
unsigned char op,
|
||
int code,
|
||
int level,
|
||
Tcl_Obj *returnOpts)
|
||
{
|
||
TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr);
|
||
TclEmitInstInt4(op, code, envPtr);
|
||
TclEmitInt4(level, envPtr);
|
||
}
|
||
|
||
void
|
||
TclCompileSyntaxError(
|
||
Tcl_Interp *interp,
|
||
CompileEnv *envPtr)
|
||
{
|
||
Tcl_Obj *msg = Tcl_GetObjResult(interp);
|
||
int numBytes;
|
||
const char *bytes = TclGetStringFromObj(msg, &numBytes);
|
||
|
||
TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr);
|
||
CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0,
|
||
Tcl_GetReturnOptions(interp, TCL_ERROR));
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileSetCmd --
|
||
*
|
||
* Procedure called to compile the "set" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "set" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileSetCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
Tcl_Token *varTokenPtr, *valueTokenPtr;
|
||
int isAssignment, isScalar, simpleVarName, localIndex, numWords;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
numWords = parsePtr->numWords;
|
||
if ((numWords != 2) && (numWords != 3)) {
|
||
return TCL_ERROR;
|
||
}
|
||
isAssignment = (numWords == 3);
|
||
|
||
/*
|
||
* Decide if we can use a frame slot for the var/array name or if we need
|
||
* to emit code to compute and push the name at runtime. We use a frame
|
||
* slot (entry in the array of local vars) if we are compiling a procedure
|
||
* body and if the name is simple text that does not include namespace
|
||
* qualifiers.
|
||
*/
|
||
|
||
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
|
||
&localIndex, &simpleVarName, &isScalar, 1);
|
||
|
||
/*
|
||
* If we are doing an assignment, push the new value.
|
||
*/
|
||
|
||
if (isAssignment) {
|
||
valueTokenPtr = TokenAfter(varTokenPtr);
|
||
CompileWord(envPtr, valueTokenPtr, interp, 2);
|
||
}
|
||
|
||
/*
|
||
* Emit instructions to set/get the variable.
|
||
*/
|
||
|
||
if (simpleVarName) {
|
||
if (isScalar) {
|
||
if (localIndex < 0) {
|
||
TclEmitOpcode((isAssignment?
|
||
INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), envPtr);
|
||
} else if (localIndex <= 255) {
|
||
TclEmitInstInt1((isAssignment?
|
||
INST_STORE_SCALAR1 : INST_LOAD_SCALAR1),
|
||
localIndex, envPtr);
|
||
} else {
|
||
TclEmitInstInt4((isAssignment?
|
||
INST_STORE_SCALAR4 : INST_LOAD_SCALAR4),
|
||
localIndex, envPtr);
|
||
}
|
||
} else {
|
||
if (localIndex < 0) {
|
||
TclEmitOpcode((isAssignment?
|
||
INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr);
|
||
} else if (localIndex <= 255) {
|
||
TclEmitInstInt1((isAssignment?
|
||
INST_STORE_ARRAY1 : INST_LOAD_ARRAY1),
|
||
localIndex, envPtr);
|
||
} else {
|
||
TclEmitInstInt4((isAssignment?
|
||
INST_STORE_ARRAY4 : INST_LOAD_ARRAY4),
|
||
localIndex, envPtr);
|
||
}
|
||
}
|
||
} else {
|
||
TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr);
|
||
}
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileStringCmpCmd --
|
||
*
|
||
* Procedure called to compile the simplest and most common form of the
|
||
* "string compare" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "string compare"
|
||
* command at runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileStringCmpCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
Tcl_Token *tokenPtr;
|
||
|
||
/*
|
||
* We don't support any flags; the bytecode isn't that sophisticated.
|
||
*/
|
||
|
||
if (parsePtr->numWords != 3) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Push the two operands onto the stack and then the test.
|
||
*/
|
||
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, 1);
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, 2);
|
||
TclEmitOpcode(INST_STR_CMP, envPtr);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileStringEqualCmd --
|
||
*
|
||
* Procedure called to compile the simplest and most common form of the
|
||
* "string equal" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "string equal" command
|
||
* at runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileStringEqualCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
Tcl_Token *tokenPtr;
|
||
|
||
/*
|
||
* We don't support any flags; the bytecode isn't that sophisticated.
|
||
*/
|
||
|
||
if (parsePtr->numWords != 3) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Push the two operands onto the stack and then the test.
|
||
*/
|
||
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, 1);
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, 2);
|
||
TclEmitOpcode(INST_STR_EQ, envPtr);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileStringIndexCmd --
|
||
*
|
||
* Procedure called to compile the simplest and most common form of the
|
||
* "string index" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "string index" command
|
||
* at runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileStringIndexCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
Tcl_Token *tokenPtr;
|
||
|
||
if (parsePtr->numWords != 3) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Push the two operands onto the stack and then the index operation.
|
||
*/
|
||
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, 1);
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, 2);
|
||
TclEmitOpcode(INST_STR_INDEX, envPtr);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileStringMatchCmd --
|
||
*
|
||
* Procedure called to compile the simplest and most common form of the
|
||
* "string match" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "string match" command
|
||
* at runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileStringMatchCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
Tcl_Token *tokenPtr;
|
||
int i, length, exactMatch = 0, nocase = 0;
|
||
const char *str;
|
||
|
||
if (parsePtr->numWords < 3 || parsePtr->numWords > 4) {
|
||
return TCL_ERROR;
|
||
}
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
|
||
/*
|
||
* Check if we have a -nocase flag.
|
||
*/
|
||
|
||
if (parsePtr->numWords == 4) {
|
||
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
|
||
return TCL_ERROR;
|
||
}
|
||
str = tokenPtr[1].start;
|
||
length = tokenPtr[1].size;
|
||
if ((length <= 1) || strncmp(str, "-nocase", (size_t) length)) {
|
||
/*
|
||
* Fail at run time, not in compilation.
|
||
*/
|
||
|
||
return TCL_ERROR;
|
||
}
|
||
nocase = 1;
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
}
|
||
|
||
/*
|
||
* Push the strings to match against each other.
|
||
*/
|
||
|
||
for (i = 0; i < 2; i++) {
|
||
if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
|
||
str = tokenPtr[1].start;
|
||
length = tokenPtr[1].size;
|
||
if (!nocase && (i == 0)) {
|
||
/*
|
||
* Trivial matches can be done by 'string equal'. If -nocase
|
||
* was specified, we can't do this because INST_STR_EQ has no
|
||
* support for nocase.
|
||
*/
|
||
|
||
Tcl_Obj *copy = Tcl_NewStringObj(str, length);
|
||
|
||
Tcl_IncrRefCount(copy);
|
||
exactMatch = TclMatchIsTrivial(TclGetString(copy));
|
||
TclDecrRefCount(copy);
|
||
}
|
||
PushLiteral(envPtr, str, length);
|
||
} else {
|
||
SetLineInformation (i+1+nocase);
|
||
CompileTokens(envPtr, tokenPtr, interp);
|
||
}
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
}
|
||
|
||
/*
|
||
* Push the matcher.
|
||
*/
|
||
|
||
if (exactMatch) {
|
||
TclEmitOpcode(INST_STR_EQ, envPtr);
|
||
} else {
|
||
TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileStringLenCmd --
|
||
*
|
||
* Procedure called to compile the simplest and most common form of the
|
||
* "string length" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "string length"
|
||
* command at runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileStringLenCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
DefineLineInformation; /* TIP #280 */
|
||
Tcl_Token *tokenPtr;
|
||
|
||
if (parsePtr->numWords != 2) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
|
||
/*
|
||
* Here someone is asking for the length of a static string. Just push
|
||
* the actual character (not byte) length.
|
||
*/
|
||
|
||
char buf[TCL_INTEGER_SPACE];
|
||
int len = Tcl_NumUtfChars(tokenPtr[1].start, tokenPtr[1].size);
|
||
|
||
len = sprintf(buf, "%d", len);
|
||
PushLiteral(envPtr, buf, len);
|
||
} else {
|
||
SetLineInformation (1);
|
||
CompileTokens(envPtr, tokenPtr, interp);
|
||
TclEmitOpcode(INST_STR_LEN, envPtr);
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileSwitchCmd --
|
||
*
|
||
* Procedure called to compile the "switch" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for successful compile, or TCL_ERROR to defer
|
||
* evaluation to runtime (either when it is too complex to get the
|
||
* semantics right, or when we know for sure that it is an error but need
|
||
* the error to happen at the right time).
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "switch" command at
|
||
* runtime.
|
||
*
|
||
* FIXME:
|
||
* Stack depths are probably not calculated correctly.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileSwitchCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
Tcl_Token *tokenPtr; /* Pointer to tokens in command. */
|
||
int numWords; /* Number of words in command. */
|
||
|
||
Tcl_Token *valueTokenPtr; /* Token for the value to switch on. */
|
||
enum {Switch_Exact, Switch_Glob, Switch_Regexp} mode;
|
||
/* What kind of switch are we doing? */
|
||
|
||
Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */
|
||
Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */
|
||
int *bodyLines; /* Array of line numbers for body list
|
||
* items. */
|
||
int** bodyNext;
|
||
int foundDefault; /* Flag to indicate whether a "default" clause
|
||
* is present. */
|
||
|
||
JumpFixup *fixupArray; /* Array of forward-jump fixup records. */
|
||
int *fixupTargetArray; /* Array of places for fixups to point at. */
|
||
int fixupCount; /* Number of places to fix up. */
|
||
int contFixIndex; /* Where the first of the jumps due to a group
|
||
* of continuation bodies starts, or -1 if
|
||
* there aren't any. */
|
||
int contFixCount; /* Number of continuation bodies pointing to
|
||
* the current (or next) real body. */
|
||
|
||
int savedStackDepth = envPtr->currStackDepth;
|
||
int noCase; /* Has the -nocase flag been given? */
|
||
int foundMode = 0; /* Have we seen a mode flag yet? */
|
||
int i, valueIndex;
|
||
DefineLineInformation; /* TIP #280 */
|
||
int* clNext = envPtr->clNext;
|
||
|
||
/*
|
||
* Only handle the following versions:
|
||
* switch ?--? word {pattern body ...}
|
||
* switch -exact ?--? word {pattern body ...}
|
||
* switch -glob ?--? word {pattern body ...}
|
||
* switch -regexp ?--? word {pattern body ...}
|
||
* switch -- word simpleWordPattern simpleWordBody ...
|
||
* switch -exact -- word simpleWordPattern simpleWordBody ...
|
||
* switch -glob -- word simpleWordPattern simpleWordBody ...
|
||
* switch -regexp -- word simpleWordPattern simpleWordBody ...
|
||
* When the mode is -glob, can also handle a -nocase flag.
|
||
*
|
||
* First off, we don't care how the command's word was generated; we're
|
||
* compiling it anyway! So skip it...
|
||
*/
|
||
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
valueIndex = 1;
|
||
numWords = parsePtr->numWords-1;
|
||
|
||
/*
|
||
* Check for options.
|
||
*/
|
||
|
||
noCase = 0;
|
||
mode = Switch_Exact;
|
||
if (numWords == 2) {
|
||
/*
|
||
* There's just the switch value and the bodies list. In that case, we
|
||
* can skip all option parsing and move on to consider switch values
|
||
* and the body list.
|
||
*/
|
||
|
||
goto finishedOptionParse;
|
||
}
|
||
|
||
/*
|
||
* There must be at least one option, --, because without that there is no
|
||
* way to statically avoid the problems you get from strings-to-be-matched
|
||
* that start with a - (the interpreted code falls apart if it encounters
|
||
* them, so we punt if we *might* encounter them as that is the easiest
|
||
* way of emulating the behaviour).
|
||
*/
|
||
|
||
for (; numWords>=3 ; tokenPtr=TokenAfter(tokenPtr),numWords--) {
|
||
register unsigned size = tokenPtr[1].size;
|
||
register const char *chrs = tokenPtr[1].start;
|
||
|
||
/*
|
||
* We only process literal options, and we assume that -e, -g and -n
|
||
* are unique prefixes of -exact, -glob and -nocase respectively (true
|
||
* at time of writing). Note that -exact and -glob may only be given
|
||
* at most once or we bail out (error case).
|
||
*/
|
||
|
||
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || size < 2) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if ((size <= 6) && !memcmp(chrs, "-exact", size)) {
|
||
if (foundMode) {
|
||
return TCL_ERROR;
|
||
}
|
||
mode = Switch_Exact;
|
||
foundMode = 1;
|
||
valueIndex++;
|
||
continue;
|
||
} else if ((size <= 5) && !memcmp(chrs, "-glob", size)) {
|
||
if (foundMode) {
|
||
return TCL_ERROR;
|
||
}
|
||
mode = Switch_Glob;
|
||
foundMode = 1;
|
||
valueIndex++;
|
||
continue;
|
||
} else if ((size <= 7) && !memcmp(chrs, "-regexp", size)) {
|
||
if (foundMode) {
|
||
return TCL_ERROR;
|
||
}
|
||
mode = Switch_Regexp;
|
||
foundMode = 1;
|
||
valueIndex++;
|
||
continue;
|
||
} else if ((size <= 7) && !memcmp(chrs, "-nocase", size)) {
|
||
noCase = 1;
|
||
valueIndex++;
|
||
continue;
|
||
} else if ((size == 2) && !memcmp(chrs, "--", 2)) {
|
||
valueIndex++;
|
||
break;
|
||
}
|
||
|
||
/*
|
||
* The switch command has many flags we cannot compile at all (e.g.
|
||
* all the RE-related ones) which we must have encountered. Either
|
||
* that or we have run off the end. The action here is the same: punt
|
||
* to interpreted version.
|
||
*/
|
||
|
||
return TCL_ERROR;
|
||
}
|
||
if (numWords < 3) {
|
||
return TCL_ERROR;
|
||
}
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
numWords--;
|
||
if (noCase && (mode == Switch_Exact)) {
|
||
/*
|
||
* Can't compile this case; no opcode for case-insensitive equality!
|
||
*/
|
||
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* The value to test against is going to always get pushed on the stack.
|
||
* But not yet; we need to verify that the rest of the command is
|
||
* compilable too.
|
||
*/
|
||
|
||
finishedOptionParse:
|
||
valueTokenPtr = tokenPtr;
|
||
/* For valueIndex, see previous loop. */
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
numWords--;
|
||
|
||
/*
|
||
* Build an array of tokens for the matcher terms and script bodies. Note
|
||
* that in the case of the quoted bodies, this is tricky as we cannot use
|
||
* copies of the string from the input token for the generated tokens (it
|
||
* causes a crash during exception handling). When multiple tokens are
|
||
* available at this point, this is pretty easy.
|
||
*/
|
||
|
||
if (numWords == 1) {
|
||
CONST char *bytes;
|
||
int maxLen, numBytes;
|
||
int bline; /* TIP #280: line of the pattern/action list,
|
||
* and start of list for when tracking the
|
||
* location. This list comes immediately after
|
||
* the value we switch on. */
|
||
|
||
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
|
||
return TCL_ERROR;
|
||
}
|
||
bytes = tokenPtr[1].start;
|
||
numBytes = tokenPtr[1].size;
|
||
|
||
/* Allocate enough space to work in. */
|
||
maxLen = TclMaxListLength(bytes, numBytes, NULL);
|
||
if (maxLen < 2) {
|
||
return TCL_ERROR;
|
||
}
|
||
bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * maxLen);
|
||
bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * maxLen);
|
||
bodyLines = (int *) ckalloc(sizeof(int) * maxLen);
|
||
bodyNext = (int **) ckalloc(sizeof(int*) * maxLen);
|
||
|
||
bline = mapPtr->loc[eclIndex].line[valueIndex+1];
|
||
numWords = 0;
|
||
|
||
while (numBytes > 0) {
|
||
CONST char *prevBytes = bytes;
|
||
int literal;
|
||
|
||
if (TCL_OK != TclFindElement(NULL, bytes, numBytes,
|
||
&(bodyTokenArray[numWords].start), &bytes,
|
||
&(bodyTokenArray[numWords].size), &literal) || !literal) {
|
||
goto abort;
|
||
}
|
||
|
||
bodyTokenArray[numWords].type = TCL_TOKEN_TEXT;
|
||
bodyTokenArray[numWords].numComponents = 0;
|
||
bodyToken[numWords] = bodyTokenArray + numWords;
|
||
|
||
/*
|
||
* TIP #280: Now determine the line the list element starts on
|
||
* (there is no need to do it earlier, due to the possibility of
|
||
* aborting, see above).
|
||
*/
|
||
|
||
TclAdvanceLines(&bline, prevBytes, bodyTokenArray[numWords].start);
|
||
TclAdvanceContinuations (&bline, &clNext,
|
||
bodyTokenArray[numWords].start - envPtr->source);
|
||
bodyLines[numWords] = bline;
|
||
bodyNext[numWords] = clNext;
|
||
TclAdvanceLines(&bline, bodyTokenArray[numWords].start, bytes);
|
||
TclAdvanceContinuations (&bline, &clNext, bytes - envPtr->source);
|
||
|
||
numBytes -= (bytes - prevBytes);
|
||
numWords++;
|
||
}
|
||
if (numWords % 2) {
|
||
abort:
|
||
ckfree((char *) bodyToken);
|
||
ckfree((char *) bodyTokenArray);
|
||
ckfree((char *) bodyLines);
|
||
ckfree((char *) bodyNext);
|
||
return TCL_ERROR;
|
||
}
|
||
} else if (numWords % 2 || numWords == 0) {
|
||
/*
|
||
* Odd number of words (>1) available, or no words at all available.
|
||
* Both are error cases, so punt and let the interpreted-version
|
||
* generate the error message. Note that the second case probably
|
||
* should get caught earlier, but it's easy to check here again anyway
|
||
* because it'd cause a nasty crash otherwise.
|
||
*/
|
||
|
||
return TCL_ERROR;
|
||
} else {
|
||
/*
|
||
* Multi-word definition of patterns & actions.
|
||
*/
|
||
|
||
bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords);
|
||
bodyLines = (int *) ckalloc(sizeof(int) * numWords);
|
||
bodyNext = (int **) ckalloc(sizeof(int*) * numWords);
|
||
bodyTokenArray = NULL;
|
||
for (i=0 ; i<numWords ; i++) {
|
||
/*
|
||
* We only handle the very simplest case. Anything more complex is
|
||
* a good reason to go to the interpreted case anyway due to
|
||
* traces, etc.
|
||
*/
|
||
|
||
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
|
||
ckfree((char *) bodyToken);
|
||
ckfree((char *) bodyLines);
|
||
ckfree((char *) bodyNext);
|
||
return TCL_ERROR;
|
||
}
|
||
bodyToken[i] = tokenPtr+1;
|
||
|
||
/*
|
||
* TIP #280: Copy line information from regular cmd info.
|
||
*/
|
||
|
||
bodyLines[i] = mapPtr->loc[eclIndex].line[valueIndex+1+i];
|
||
bodyNext[i] = mapPtr->loc[eclIndex].next[valueIndex+1+i];
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Fall back to interpreted if the last body is a continuation (it's
|
||
* illegal, but this makes the error happen at the right time).
|
||
*/
|
||
|
||
if (bodyToken[numWords-1]->size == 1 &&
|
||
bodyToken[numWords-1]->start[0] == '-') {
|
||
ckfree((char *) bodyToken);
|
||
ckfree((char *) bodyLines);
|
||
ckfree((char *) bodyNext);
|
||
if (bodyTokenArray != NULL) {
|
||
ckfree((char *) bodyTokenArray);
|
||
}
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Now we commit to generating code; the parsing stage per se is done.
|
||
* First, we push the value we're matching against on the stack.
|
||
*/
|
||
|
||
SetLineInformation (valueIndex);
|
||
CompileTokens(envPtr, valueTokenPtr, interp);
|
||
|
||
/*
|
||
* Check if we can generate a jump table, since if so that's faster than
|
||
* doing an explicit compare with each body. Note that we're definitely
|
||
* over-conservative with determining whether we can do the jump table,
|
||
* but it handles the most common case well enough.
|
||
*/
|
||
|
||
if (mode == Switch_Exact) {
|
||
JumptableInfo *jtPtr;
|
||
int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation;
|
||
int mustGenerate, jumpToDefault;
|
||
Tcl_DString buffer;
|
||
Tcl_HashEntry *hPtr;
|
||
|
||
/*
|
||
* Compile the switch by using a jump table, which is basically a
|
||
* hashtable that maps from literal values to match against to the
|
||
* offset (relative to the INST_JUMP_TABLE instruction) to jump to.
|
||
* The jump table itself is independent of any invokation of the
|
||
* bytecode, and as such is stored in an auxData block.
|
||
*
|
||
* Start by allocating the jump table itself, plus some workspace.
|
||
*/
|
||
|
||
jtPtr = (JumptableInfo *) ckalloc(sizeof(JumptableInfo));
|
||
Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);
|
||
infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr);
|
||
finalFixups = (int *) ckalloc(sizeof(int) * (numWords/2));
|
||
foundDefault = 0;
|
||
mustGenerate = 1;
|
||
|
||
/*
|
||
* Next, issue the instruction to do the jump, together with what we
|
||
* want to do if things do not work out (jump to either the default
|
||
* clause or the "default" default, which just sets the result to
|
||
* empty). Note that we will come back and rewrite the jump's offset
|
||
* parameter when we know what it should be, and that all jumps we
|
||
* issue are of the wide kind because that makes the code much easier
|
||
* to debug!
|
||
*/
|
||
|
||
jumpLocation = CurrentOffset(envPtr);
|
||
TclEmitInstInt4(INST_JUMP_TABLE, infoIndex, envPtr);
|
||
jumpToDefault = CurrentOffset(envPtr);
|
||
TclEmitInstInt4(INST_JUMP4, 0, envPtr);
|
||
|
||
for (i=0 ; i<numWords ; i+=2) {
|
||
/*
|
||
* For each arm, we must first work out what to do with the match
|
||
* term.
|
||
*/
|
||
|
||
if (i!=numWords-2 || bodyToken[numWords-2]->size != 7 ||
|
||
memcmp(bodyToken[numWords-2]->start, "default", 7)) {
|
||
/*
|
||
* This is not a default clause, so insert the current
|
||
* location as a target in the jump table (assuming it isn't
|
||
* already there, which would indicate that this clause is
|
||
* probably masked by an earlier one). Note that we use a
|
||
* Tcl_DString here simply because the hash API does not let
|
||
* us specify the string length.
|
||
*/
|
||
|
||
Tcl_DStringInit(&buffer);
|
||
Tcl_DStringAppend(&buffer, bodyToken[i]->start,
|
||
bodyToken[i]->size);
|
||
hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable,
|
||
Tcl_DStringValue(&buffer), &isNew);
|
||
if (isNew) {
|
||
/*
|
||
* First time we've encountered this match clause, so it
|
||
* must point to here.
|
||
*/
|
||
|
||
Tcl_SetHashValue(hPtr, (ClientData)
|
||
(CurrentOffset(envPtr) - jumpLocation));
|
||
}
|
||
Tcl_DStringFree(&buffer);
|
||
} else {
|
||
/*
|
||
* This is a default clause, so patch up the fallthrough from
|
||
* the INST_JUMP_TABLE instruction to here.
|
||
*/
|
||
|
||
foundDefault = 1;
|
||
isNew = 1;
|
||
TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault,
|
||
envPtr->codeStart+jumpToDefault+1);
|
||
}
|
||
|
||
/*
|
||
* Now, for each arm we must deal with the body of the clause.
|
||
*
|
||
* If this is a continuation body (never true of a final clause,
|
||
* whether default or not) we're done because the next jump target
|
||
* will also point here, so we advance to the next clause.
|
||
*/
|
||
|
||
if (bodyToken[i+1]->size == 1 && bodyToken[i+1]->start[0] == '-') {
|
||
mustGenerate = 1;
|
||
continue;
|
||
}
|
||
|
||
/*
|
||
* Also skip this arm if its only match clause is masked. (We
|
||
* could probably be more aggressive about this, but that would be
|
||
* much more difficult to get right.)
|
||
*/
|
||
|
||
if (!isNew && !mustGenerate) {
|
||
continue;
|
||
}
|
||
mustGenerate = 0;
|
||
|
||
/*
|
||
* Compile the body of the arm.
|
||
*/
|
||
|
||
envPtr->line = bodyLines[i+1]; /* TIP #280 */
|
||
envPtr->clNext = bodyNext[i+1]; /* TIP #280 */
|
||
TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
|
||
|
||
/*
|
||
* Compile a jump in to the end of the command if this body is
|
||
* anything other than a user-supplied default arm (to either skip
|
||
* over the remaining bodies or the code that generates an empty
|
||
* result).
|
||
*/
|
||
|
||
if (i+2 < numWords || !foundDefault) {
|
||
finalFixups[numRealBodies++] = CurrentOffset(envPtr);
|
||
|
||
/*
|
||
* Easier by far to issue this jump as a fixed-width jump.
|
||
* Otherwise we'd need to do a lot more (and more awkward)
|
||
* rewriting when we fixed this all up.
|
||
*/
|
||
|
||
TclEmitInstInt4(INST_JUMP4, 0, envPtr);
|
||
}
|
||
}
|
||
|
||
/*
|
||
* We're at the end. If we've not already done so through the
|
||
* processing of a user-supplied default clause, add in a "default"
|
||
* default clause now.
|
||
*/
|
||
|
||
if (!foundDefault) {
|
||
TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault,
|
||
envPtr->codeStart+jumpToDefault+1);
|
||
PushLiteral(envPtr, "", 0);
|
||
}
|
||
|
||
/*
|
||
* No more instructions to be issued; everything that needs to jump to
|
||
* the end of the command is fixed up at this point.
|
||
*/
|
||
|
||
for (i=0 ; i<numRealBodies ; i++) {
|
||
TclStoreInt4AtPtr(CurrentOffset(envPtr)-finalFixups[i],
|
||
envPtr->codeStart+finalFixups[i]+1);
|
||
}
|
||
|
||
/*
|
||
* Clean up all our temporary space and return.
|
||
*/
|
||
|
||
ckfree((char *) finalFixups);
|
||
ckfree((char *) bodyToken);
|
||
ckfree((char *) bodyLines);
|
||
ckfree((char *) bodyNext);
|
||
if (bodyTokenArray != NULL) {
|
||
ckfree((char *) bodyTokenArray);
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* Generate a test for each arm.
|
||
*/
|
||
|
||
contFixIndex = -1;
|
||
contFixCount = 0;
|
||
fixupArray = (JumpFixup *) ckalloc(sizeof(JumpFixup) * numWords);
|
||
fixupTargetArray = (int *) ckalloc(sizeof(int) * numWords);
|
||
memset(fixupTargetArray, 0, numWords * sizeof(int));
|
||
fixupCount = 0;
|
||
foundDefault = 0;
|
||
for (i=0 ; i<numWords ; i+=2) {
|
||
int nextArmFixupIndex = -1;
|
||
|
||
envPtr->currStackDepth = savedStackDepth + 1;
|
||
if (i!=numWords-2 || bodyToken[numWords-2]->size != 7 ||
|
||
memcmp(bodyToken[numWords-2]->start, "default", 7)) {
|
||
/*
|
||
* Generate the test for the arm.
|
||
*/
|
||
|
||
switch (mode) {
|
||
case Switch_Exact:
|
||
TclEmitOpcode(INST_DUP, envPtr);
|
||
TclCompileTokens(interp, bodyToken[i], 1, envPtr);
|
||
TclEmitOpcode(INST_STR_EQ, envPtr);
|
||
break;
|
||
case Switch_Glob:
|
||
TclCompileTokens(interp, bodyToken[i], 1, envPtr);
|
||
TclEmitInstInt4(INST_OVER, 1, envPtr);
|
||
TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr);
|
||
break;
|
||
case Switch_Regexp: {
|
||
int simple = 0, exact = 0;
|
||
|
||
/*
|
||
* Keep in sync with TclCompileRegexpCmd.
|
||
*/
|
||
|
||
if (bodyToken[i]->type == TCL_TOKEN_TEXT) {
|
||
Tcl_DString ds;
|
||
|
||
if (bodyToken[i]->size == 0) {
|
||
/*
|
||
* The semantics of regexps are that they always match
|
||
* when the RE == "".
|
||
*/
|
||
|
||
PushLiteral(envPtr, "1", 1);
|
||
break;
|
||
}
|
||
|
||
/*
|
||
* Attempt to convert pattern to glob. If successful, push
|
||
* the converted pattern.
|
||
*/
|
||
|
||
if (TclReToGlob(NULL, bodyToken[i]->start,
|
||
bodyToken[i]->size, &ds, &exact) == TCL_OK) {
|
||
simple = 1;
|
||
PushLiteral(envPtr, Tcl_DStringValue(&ds),
|
||
Tcl_DStringLength(&ds));
|
||
Tcl_DStringFree(&ds);
|
||
}
|
||
}
|
||
if (!simple) {
|
||
TclCompileTokens(interp, bodyToken[i], 1, envPtr);
|
||
}
|
||
|
||
TclEmitInstInt4(INST_OVER, 1, envPtr);
|
||
if (simple) {
|
||
if (exact && !noCase) {
|
||
TclEmitOpcode(INST_STR_EQ, envPtr);
|
||
} else {
|
||
TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr);
|
||
}
|
||
} else {
|
||
/*
|
||
* Pass correct RE compile flags. We use only Int1
|
||
* (8-bit), but that handles all the flags we want to
|
||
* pass. Don't use TCL_REG_NOSUB as we may have backrefs
|
||
* or capture vars.
|
||
*/
|
||
|
||
int cflags = TCL_REG_ADVANCED
|
||
| (noCase ? TCL_REG_NOCASE : 0);
|
||
|
||
TclEmitInstInt1(INST_REGEXP, cflags, envPtr);
|
||
}
|
||
break;
|
||
}
|
||
default:
|
||
Tcl_Panic("unknown switch mode: %d", mode);
|
||
}
|
||
|
||
/*
|
||
* In a fall-through case, we will jump on _true_ to the place
|
||
* where the body starts (generated later, with guarantee of this
|
||
* ensured earlier; the final body is never a fall-through).
|
||
*/
|
||
|
||
if (bodyToken[i+1]->size==1 && bodyToken[i+1]->start[0]=='-') {
|
||
if (contFixIndex == -1) {
|
||
contFixIndex = fixupCount;
|
||
contFixCount = 0;
|
||
}
|
||
TclEmitForwardJump(envPtr, TCL_TRUE_JUMP,
|
||
fixupArray+contFixIndex+contFixCount);
|
||
fixupCount++;
|
||
contFixCount++;
|
||
continue;
|
||
}
|
||
|
||
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, fixupArray+fixupCount);
|
||
nextArmFixupIndex = fixupCount;
|
||
fixupCount++;
|
||
} else {
|
||
/*
|
||
* Got a default clause; set a flag to inhibit the generation of
|
||
* the jump after the body and the cleanup of the intermediate
|
||
* value that we are switching against.
|
||
*
|
||
* Note that default clauses (which are always terminal clauses)
|
||
* cannot be fall-through clauses as well, since the last clause
|
||
* is never a fall-through clause (which we have already
|
||
* verified).
|
||
*/
|
||
|
||
foundDefault = 1;
|
||
}
|
||
|
||
/*
|
||
* Generate the body for the arm. This is guaranteed not to be a
|
||
* fall-through case, but it might have preceding fall-through cases,
|
||
* so we must process those first.
|
||
*/
|
||
|
||
if (contFixIndex != -1) {
|
||
int j;
|
||
|
||
for (j=0 ; j<contFixCount ; j++) {
|
||
fixupTargetArray[contFixIndex+j] = CurrentOffset(envPtr);
|
||
}
|
||
contFixIndex = -1;
|
||
}
|
||
|
||
/*
|
||
* Now do the actual compilation. Note that we do not use CompileBody
|
||
* because we may have synthesized the tokens in a non-standard
|
||
* pattern.
|
||
*/
|
||
|
||
TclEmitOpcode(INST_POP, envPtr);
|
||
envPtr->currStackDepth = savedStackDepth + 1;
|
||
envPtr->line = bodyLines[i+1]; /* TIP #280 */
|
||
envPtr->clNext = bodyNext[i+1]; /* TIP #280 */
|
||
TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
|
||
|
||
if (!foundDefault) {
|
||
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
|
||
fixupArray+fixupCount);
|
||
fixupCount++;
|
||
fixupTargetArray[nextArmFixupIndex] = CurrentOffset(envPtr);
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Clean up all our temporary space and return.
|
||
*/
|
||
|
||
ckfree((char *) bodyToken);
|
||
ckfree((char *) bodyLines);
|
||
ckfree((char *) bodyNext);
|
||
if (bodyTokenArray != NULL) {
|
||
ckfree((char *) bodyTokenArray);
|
||
}
|
||
|
||
/*
|
||
* Discard the value we are matching against unless we've had a default
|
||
* clause (in which case it will already be gone due to the code at the
|
||
* start of processing an arm, guaranteed) and make the result of the
|
||
* command an empty string.
|
||
*/
|
||
|
||
if (!foundDefault) {
|
||
TclEmitOpcode(INST_POP, envPtr);
|
||
PushLiteral(envPtr, "", 0);
|
||
}
|
||
|
||
/*
|
||
* Do jump fixups for arms that were executed. First, fill in the jumps of
|
||
* all jumps that don't point elsewhere to point to here.
|
||
*/
|
||
|
||
for (i=0 ; i<fixupCount ; i++) {
|
||
if (fixupTargetArray[i] == 0) {
|
||
fixupTargetArray[i] = envPtr->codeNext-envPtr->codeStart;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Now scan backwards over all the jumps (all of which are forward jumps)
|
||
* doing each one. When we do one and there is a size changes, we must
|
||
* scan back over all the previous ones and see if they need adjusting
|
||
* before proceeding with further jump fixups (the interleaved nature of
|
||
* all the jumps makes this impossible to do without nested loops).
|
||
*/
|
||
|
||
for (i=fixupCount-1 ; i>=0 ; i--) {
|
||
if (TclFixupForwardJump(envPtr, &fixupArray[i],
|
||
fixupTargetArray[i] - fixupArray[i].codeOffset, 127)) {
|
||
int j;
|
||
|
||
for (j=i-1 ; j>=0 ; j--) {
|
||
if (fixupTargetArray[j] > fixupArray[i].codeOffset) {
|
||
fixupTargetArray[j] += 3;
|
||
}
|
||
}
|
||
}
|
||
}
|
||
ckfree((char *) fixupArray);
|
||
ckfree((char *) fixupTargetArray);
|
||
|
||
envPtr->currStackDepth = savedStackDepth + 1;
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* DupJumptableInfo, FreeJumptableInfo --
|
||
*
|
||
* Functions to duplicate, release and print a jump-table created for use
|
||
* with the INST_JUMP_TABLE instruction.
|
||
*
|
||
* Results:
|
||
* DupJumptableInfo: a copy of the jump-table
|
||
* FreeJumptableInfo: none
|
||
* PrintJumptableInfo: none
|
||
*
|
||
* Side effects:
|
||
* DupJumptableInfo: allocates memory
|
||
* FreeJumptableInfo: releases memory
|
||
* PrintJumptableInfo: none
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static ClientData
|
||
DupJumptableInfo(
|
||
ClientData clientData)
|
||
{
|
||
JumptableInfo *jtPtr = clientData;
|
||
JumptableInfo *newJtPtr = (JumptableInfo *)
|
||
ckalloc(sizeof(JumptableInfo));
|
||
Tcl_HashEntry *hPtr, *newHPtr;
|
||
Tcl_HashSearch search;
|
||
int isNew;
|
||
|
||
Tcl_InitHashTable(&newJtPtr->hashTable, TCL_STRING_KEYS);
|
||
hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
|
||
while (hPtr != NULL) {
|
||
newHPtr = Tcl_CreateHashEntry(&newJtPtr->hashTable,
|
||
Tcl_GetHashKey(&jtPtr->hashTable, hPtr), &isNew);
|
||
Tcl_SetHashValue(newHPtr, Tcl_GetHashValue(hPtr));
|
||
}
|
||
return newJtPtr;
|
||
}
|
||
|
||
static void
|
||
FreeJumptableInfo(
|
||
ClientData clientData)
|
||
{
|
||
JumptableInfo *jtPtr = clientData;
|
||
|
||
Tcl_DeleteHashTable(&jtPtr->hashTable);
|
||
ckfree((char *) jtPtr);
|
||
}
|
||
|
||
static void
|
||
PrintJumptableInfo(
|
||
ClientData clientData,
|
||
Tcl_Obj *appendObj,
|
||
ByteCode *codePtr,
|
||
unsigned int pcOffset)
|
||
{
|
||
register JumptableInfo *jtPtr = clientData;
|
||
Tcl_HashEntry *hPtr;
|
||
Tcl_HashSearch search;
|
||
const char *keyPtr;
|
||
int offset, i = 0;
|
||
|
||
hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
|
||
for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) {
|
||
keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
|
||
offset = PTR2INT(Tcl_GetHashValue(hPtr));
|
||
|
||
if (i++) {
|
||
Tcl_AppendToObj(appendObj, ", ", -1);
|
||
if (i%4==0) {
|
||
Tcl_AppendToObj(appendObj, "\n\t\t", -1);
|
||
}
|
||
}
|
||
Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %d",
|
||
keyPtr, pcOffset + offset);
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileWhileCmd --
|
||
*
|
||
* Procedure called to compile the "while" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "while" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileWhileCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
Tcl_Token *testTokenPtr, *bodyTokenPtr;
|
||
JumpFixup jumpEvalCondFixup;
|
||
int testCodeOffset, bodyCodeOffset, jumpDist, range, code, boolVal;
|
||
int savedStackDepth = envPtr->currStackDepth;
|
||
int loopMayEnd = 1; /* This is set to 0 if it is recognized as an
|
||
* infinite loop. */
|
||
Tcl_Obj *boolObj;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
if (parsePtr->numWords != 3) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* If the test expression requires substitutions, don't compile the while
|
||
* command inline. E.g., the expression might cause the loop to never
|
||
* execute or execute forever, as in "while "$x < 5" {}".
|
||
*
|
||
* Bail out also if the body expression requires substitutions in order to
|
||
* insure correct behaviour [Bug 219166]
|
||
*/
|
||
|
||
testTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
bodyTokenPtr = TokenAfter(testTokenPtr);
|
||
|
||
if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
|
||
|| (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Find out if the condition is a constant.
|
||
*/
|
||
|
||
boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size);
|
||
Tcl_IncrRefCount(boolObj);
|
||
code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
|
||
TclDecrRefCount(boolObj);
|
||
if (code == TCL_OK) {
|
||
if (boolVal) {
|
||
/*
|
||
* It is an infinite loop; flag it so that we generate a more
|
||
* efficient body.
|
||
*/
|
||
|
||
loopMayEnd = 0;
|
||
} else {
|
||
/*
|
||
* This is an empty loop: "while 0 {...}" or such. Compile no
|
||
* bytecodes.
|
||
*/
|
||
|
||
goto pushResult;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Create a ExceptionRange record for the loop body. This is used to
|
||
* implement break and continue.
|
||
*/
|
||
|
||
range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
|
||
|
||
/*
|
||
* Jump to the evaluation of the condition. This code uses the "loop
|
||
* rotation" optimisation (which eliminates one branch from the loop).
|
||
* "while cond body" produces then:
|
||
* goto A
|
||
* B: body : bodyCodeOffset
|
||
* A: cond -> result : testCodeOffset, continueOffset
|
||
* if (result) goto B
|
||
*
|
||
* The infinite loop "while 1 body" produces:
|
||
* B: body : all three offsets here
|
||
* goto B
|
||
*/
|
||
|
||
if (loopMayEnd) {
|
||
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);
|
||
testCodeOffset = 0; /* Avoid compiler warning. */
|
||
} else {
|
||
/*
|
||
* Make sure that the first command in the body is preceded by an
|
||
* INST_START_CMD, and hence counted properly. [Bug 1752146]
|
||
*/
|
||
|
||
envPtr->atCmdStart = 0;
|
||
testCodeOffset = CurrentOffset(envPtr);
|
||
}
|
||
|
||
/*
|
||
* Compile the loop body.
|
||
*/
|
||
|
||
SetLineInformation (2);
|
||
bodyCodeOffset = ExceptionRangeStarts(envPtr, range);
|
||
CompileBody(envPtr, bodyTokenPtr, interp);
|
||
ExceptionRangeEnds(envPtr, range);
|
||
envPtr->currStackDepth = savedStackDepth + 1;
|
||
TclEmitOpcode(INST_POP, envPtr);
|
||
|
||
/*
|
||
* Compile the test expression then emit the conditional jump that
|
||
* terminates the while. We already know it's a simple word.
|
||
*/
|
||
|
||
if (loopMayEnd) {
|
||
testCodeOffset = CurrentOffset(envPtr);
|
||
jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
|
||
if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
|
||
bodyCodeOffset += 3;
|
||
testCodeOffset += 3;
|
||
}
|
||
envPtr->currStackDepth = savedStackDepth;
|
||
SetLineInformation (1);
|
||
TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
|
||
envPtr->currStackDepth = savedStackDepth + 1;
|
||
|
||
jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
|
||
if (jumpDist > 127) {
|
||
TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
|
||
} else {
|
||
TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
|
||
}
|
||
} else {
|
||
jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
|
||
if (jumpDist > 127) {
|
||
TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr);
|
||
} else {
|
||
TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr);
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Set the loop's body, continue and break offsets.
|
||
*/
|
||
|
||
envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
|
||
envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset;
|
||
ExceptionRangeTarget(envPtr, range, breakOffset);
|
||
|
||
/*
|
||
* The while command's result is an empty string.
|
||
*/
|
||
|
||
pushResult:
|
||
envPtr->currStackDepth = savedStackDepth;
|
||
PushLiteral(envPtr, "", 0);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* LocalScalar(FromToken) --
|
||
*
|
||
* 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 entry into the table of compiled locals.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
LocalScalarFromToken(
|
||
Tcl_Token *tokenPtr,
|
||
CompileEnv *envPtr)
|
||
{
|
||
int isSimple, isScalar, index;
|
||
|
||
PushVarName(NULL, tokenPtr, envPtr, TCL_CREATE_VAR, &index,
|
||
&isSimple, &isScalar, 0 /* ignored */, NULL /* ignored */);
|
||
if (!isScalar) {
|
||
index = -1;
|
||
}
|
||
return index;
|
||
}
|
||
|
||
static int
|
||
LocalScalar(
|
||
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 LocalScalarFromToken(token, envPtr);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* PushVarName --
|
||
*
|
||
* Procedure used in the compiling where pushing a variable name is
|
||
* necessary (append, lappend, set).
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "set" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
PushVarName(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Token *varTokenPtr, /* Points to a variable token. */
|
||
CompileEnv *envPtr, /* Holds resulting instructions. */
|
||
int flags, /* TCL_CREATE_VAR or TCL_NO_LARGE_INDEX. */
|
||
int *localIndexPtr, /* Must not be NULL. */
|
||
int *simpleVarNamePtr, /* Must not be NULL. */
|
||
int *isScalarPtr, /* Must not be NULL. */
|
||
int line, /* Line the token starts on. */
|
||
int* clNext) /* Reference to offset of next hidden cont. line */
|
||
{
|
||
register const char *p;
|
||
const char *name, *elName;
|
||
register int i, n;
|
||
Tcl_Token *elemTokenPtr = NULL;
|
||
int nameChars, elNameChars, simpleVarName, localIndex;
|
||
int elemTokenCount = 0, allocedTokens = 0, removedParen = 0;
|
||
|
||
/*
|
||
* Decide if we can use a frame slot for the var/array name or if we need
|
||
* to emit code to compute and push the name at runtime. We use a frame
|
||
* slot (entry in the array of local vars) if we are compiling a procedure
|
||
* body and if the name is simple text that does not include namespace
|
||
* qualifiers.
|
||
*/
|
||
|
||
simpleVarName = 0;
|
||
name = elName = NULL;
|
||
nameChars = elNameChars = 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;
|
||
nameChars = varTokenPtr[1].size;
|
||
if (name[nameChars-1] == ')') {
|
||
/*
|
||
* last char is ')' => potential array reference.
|
||
*/
|
||
|
||
for (i=0,p=name ; i<nameChars ; i++,p++) {
|
||
if (*p == '(') {
|
||
elName = p + 1;
|
||
elNameChars = nameChars - i - 2;
|
||
nameChars = i;
|
||
break;
|
||
}
|
||
}
|
||
|
||
if (interp && (elName != NULL) && elNameChars) {
|
||
/*
|
||
* An array element, the element name is a simple string:
|
||
* assemble the corresponding token.
|
||
*/
|
||
|
||
elemTokenPtr = (Tcl_Token *) TclStackAlloc(interp,
|
||
sizeof(Tcl_Token));
|
||
allocedTokens = 1;
|
||
elemTokenPtr->type = TCL_TOKEN_TEXT;
|
||
elemTokenPtr->start = elName;
|
||
elemTokenPtr->size = elNameChars;
|
||
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 (i = 0, p = varTokenPtr[1].start;
|
||
i < varTokenPtr[1].size; i++, p++) {
|
||
if (*p == '(') {
|
||
simpleVarName = 1;
|
||
break;
|
||
}
|
||
}
|
||
if (simpleVarName) {
|
||
int remainingChars;
|
||
|
||
/*
|
||
* Check the last token: if it is just ')', do not count it.
|
||
* Otherwise, remove the ')' and flag so that it is restored at
|
||
* the end.
|
||
*/
|
||
|
||
if (varTokenPtr[n].size == 1) {
|
||
--n;
|
||
} else {
|
||
--varTokenPtr[n].size;
|
||
removedParen = n;
|
||
}
|
||
|
||
name = varTokenPtr[1].start;
|
||
nameChars = p - varTokenPtr[1].start;
|
||
elName = p + 1;
|
||
remainingChars = (varTokenPtr[2].start - p) - 1;
|
||
elNameChars = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 1;
|
||
|
||
if (remainingChars) {
|
||
/*
|
||
* Make a first token with the extra characters in the first
|
||
* token.
|
||
*/
|
||
|
||
elemTokenPtr = (Tcl_Token *) TclStackAlloc(interp,
|
||
n * sizeof(Tcl_Token));
|
||
allocedTokens = 1;
|
||
elemTokenPtr->type = TCL_TOKEN_TEXT;
|
||
elemTokenPtr->start = elName;
|
||
elemTokenPtr->size = remainingChars;
|
||
elemTokenPtr->numComponents = 0;
|
||
elemTokenCount = n;
|
||
|
||
/*
|
||
* Copy the remaining tokens.
|
||
*/
|
||
|
||
memcpy(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 (i = 0, p = name; i < nameChars; i++, p++) {
|
||
if ((*p == ':') && ((i+1) < nameChars) && (*(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 ((envPtr->procPtr != NULL) && !hasNsQualifiers) {
|
||
localIndex = TclFindCompiledLocal(name, nameChars,
|
||
/*create*/ flags & TCL_CREATE_VAR,
|
||
envPtr->procPtr);
|
||
if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
|
||
/*
|
||
* We'll push the name.
|
||
*/
|
||
|
||
localIndex = -1;
|
||
}
|
||
}
|
||
if (interp && localIndex < 0) {
|
||
PushLiteral(envPtr, name, nameChars);
|
||
}
|
||
|
||
/*
|
||
* Compile the element script, if any.
|
||
*/
|
||
|
||
if (interp && elName != NULL) {
|
||
if (elNameChars) {
|
||
envPtr->line = line;
|
||
envPtr->clNext = clNext;
|
||
TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr);
|
||
} else {
|
||
PushLiteral(envPtr, "", 0);
|
||
}
|
||
}
|
||
} else if (interp) {
|
||
/*
|
||
* The var name isn't simple: compile and push it.
|
||
*/
|
||
|
||
envPtr->line = line;
|
||
envPtr->clNext = clNext;
|
||
CompileTokens(envPtr, varTokenPtr, interp);
|
||
}
|
||
|
||
if (removedParen) {
|
||
++varTokenPtr[removedParen].size;
|
||
}
|
||
if (allocedTokens) {
|
||
TclStackFree(interp, elemTokenPtr);
|
||
}
|
||
*localIndexPtr = localIndex;
|
||
*simpleVarNamePtr = simpleVarName;
|
||
*isScalarPtr = (elName == NULL);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* CompileUnaryOpCmd --
|
||
*
|
||
* Utility routine to compile the unary operator commands.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the compiled command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
CompileUnaryOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
int instruction,
|
||
CompileEnv *envPtr)
|
||
{
|
||
Tcl_Token *tokenPtr;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
if (parsePtr->numWords != 2) {
|
||
return TCL_ERROR;
|
||
}
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, 1);
|
||
TclEmitOpcode(instruction, envPtr);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* CompileAssociativeBinaryOpCmd --
|
||
*
|
||
* Utility routine to compile the binary operator commands that accept an
|
||
* arbitrary number of arguments, and that are associative operations.
|
||
* Because of the associativity, we may combine operations from right to
|
||
* left, saving us any effort of re-ordering the arguments on the stack
|
||
* after substitutions are completed.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the compiled command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
CompileAssociativeBinaryOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
const char *identity,
|
||
int instruction,
|
||
CompileEnv *envPtr)
|
||
{
|
||
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
|
||
DefineLineInformation; /* TIP #280 */
|
||
int words;
|
||
|
||
for (words=1 ; words<parsePtr->numWords ; words++) {
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, words);
|
||
}
|
||
if (parsePtr->numWords <= 2) {
|
||
PushLiteral(envPtr, identity, -1);
|
||
words++;
|
||
}
|
||
if (words > 3) {
|
||
/*
|
||
* Reverse order of arguments to get precise agreement with
|
||
* [expr] in calcuations, including roundoff errors.
|
||
*/
|
||
TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
|
||
}
|
||
while (--words > 1) {
|
||
TclEmitOpcode(instruction, envPtr);
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* CompileStrictlyBinaryOpCmd --
|
||
*
|
||
* Utility routine to compile the binary operator commands, that strictly
|
||
* accept exactly two arguments.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the compiled command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
CompileStrictlyBinaryOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
int instruction,
|
||
CompileEnv *envPtr)
|
||
{
|
||
if (parsePtr->numWords != 3) {
|
||
return TCL_ERROR;
|
||
}
|
||
return CompileAssociativeBinaryOpCmd(interp, parsePtr,
|
||
NULL, instruction, envPtr);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* CompileComparisonOpCmd --
|
||
*
|
||
* Utility routine to compile the n-ary comparison operator commands.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the compiled command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
CompileComparisonOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
int instruction,
|
||
CompileEnv *envPtr)
|
||
{
|
||
Tcl_Token *tokenPtr;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
if (parsePtr->numWords < 3) {
|
||
PushLiteral(envPtr, "1", 1);
|
||
} else if (parsePtr->numWords == 3) {
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, 1);
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, 2);
|
||
TclEmitOpcode(instruction, envPtr);
|
||
} else if (envPtr->procPtr == NULL) {
|
||
/*
|
||
* No local variable space!
|
||
*/
|
||
|
||
return TCL_ERROR;
|
||
} else {
|
||
int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr->procPtr);
|
||
int words;
|
||
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, 1);
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, 2);
|
||
if (tmpIndex <= 255) {
|
||
TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
|
||
} else {
|
||
TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
|
||
}
|
||
TclEmitOpcode(instruction, envPtr);
|
||
for (words=3 ; words<parsePtr->numWords ;) {
|
||
if (tmpIndex <= 255) {
|
||
TclEmitInstInt1(INST_LOAD_SCALAR1, tmpIndex, envPtr);
|
||
} else {
|
||
TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr);
|
||
}
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, words);
|
||
if (++words < parsePtr->numWords) {
|
||
if (tmpIndex <= 255) {
|
||
TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
|
||
} else {
|
||
TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
|
||
}
|
||
}
|
||
TclEmitOpcode(instruction, envPtr);
|
||
}
|
||
for (; words>3 ; words--) {
|
||
TclEmitOpcode(INST_BITAND, envPtr);
|
||
}
|
||
|
||
/*
|
||
* Drop the value from the temp variable; retaining that reference
|
||
* might be expensive elsewhere.
|
||
*/
|
||
|
||
PushLiteral(envPtr, "", 0);
|
||
if (tmpIndex <= 255) {
|
||
TclEmitInstInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
|
||
} else {
|
||
TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
|
||
}
|
||
TclEmitOpcode(INST_POP, envPtr);
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompile*OpCmd --
|
||
*
|
||
* Procedures called to compile the corresponding "::tcl::mathop::*"
|
||
* commands. These are all wrappers around the utility operator command
|
||
* compiler functions, except for the compilers for subtraction and
|
||
* division, which are special.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the compiled command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileInvertOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr)
|
||
{
|
||
return CompileUnaryOpCmd(interp, parsePtr, INST_BITNOT, envPtr);
|
||
}
|
||
|
||
int
|
||
TclCompileNotOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr)
|
||
{
|
||
return CompileUnaryOpCmd(interp, parsePtr, INST_LNOT, envPtr);
|
||
}
|
||
|
||
int
|
||
TclCompileAddOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr)
|
||
{
|
||
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_ADD,
|
||
envPtr);
|
||
}
|
||
|
||
int
|
||
TclCompileMulOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr)
|
||
{
|
||
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "1", INST_MULT,
|
||
envPtr);
|
||
}
|
||
|
||
int
|
||
TclCompileAndOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr)
|
||
{
|
||
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "-1", INST_BITAND,
|
||
envPtr);
|
||
}
|
||
|
||
int
|
||
TclCompileOrOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr)
|
||
{
|
||
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITOR,
|
||
envPtr);
|
||
}
|
||
|
||
int
|
||
TclCompileXorOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr)
|
||
{
|
||
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITXOR,
|
||
envPtr);
|
||
}
|
||
|
||
int
|
||
TclCompilePowOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr)
|
||
{
|
||
/*
|
||
* This one has its own implementation because the ** operator is
|
||
* the only one with right associativity.
|
||
*/
|
||
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
|
||
DefineLineInformation; /* TIP #280 */
|
||
int words;
|
||
|
||
for (words=1 ; words<parsePtr->numWords ; words++) {
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, words);
|
||
}
|
||
if (parsePtr->numWords <= 2) {
|
||
PushLiteral(envPtr, "1", 1);
|
||
words++;
|
||
}
|
||
while (--words > 1) {
|
||
TclEmitOpcode(INST_EXPON, envPtr);
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
int
|
||
TclCompileLshiftOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr)
|
||
{
|
||
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LSHIFT, envPtr);
|
||
}
|
||
|
||
int
|
||
TclCompileRshiftOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr)
|
||
{
|
||
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_RSHIFT, envPtr);
|
||
}
|
||
|
||
int
|
||
TclCompileModOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr)
|
||
{
|
||
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_MOD, envPtr);
|
||
}
|
||
|
||
int
|
||
TclCompileNeqOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr)
|
||
{
|
||
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_NEQ, envPtr);
|
||
}
|
||
|
||
int
|
||
TclCompileStrneqOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr)
|
||
{
|
||
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_STR_NEQ, envPtr);
|
||
}
|
||
|
||
int
|
||
TclCompileInOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr)
|
||
{
|
||
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_IN, envPtr);
|
||
}
|
||
|
||
int
|
||
TclCompileNiOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr)
|
||
{
|
||
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_NOT_IN,
|
||
envPtr);
|
||
}
|
||
|
||
int
|
||
TclCompileLessOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr)
|
||
{
|
||
return CompileComparisonOpCmd(interp, parsePtr, INST_LT, envPtr);
|
||
}
|
||
|
||
int
|
||
TclCompileLeqOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr)
|
||
{
|
||
return CompileComparisonOpCmd(interp, parsePtr, INST_LE, envPtr);
|
||
}
|
||
|
||
int
|
||
TclCompileGreaterOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr)
|
||
{
|
||
return CompileComparisonOpCmd(interp, parsePtr, INST_GT, envPtr);
|
||
}
|
||
|
||
int
|
||
TclCompileGeqOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr)
|
||
{
|
||
return CompileComparisonOpCmd(interp, parsePtr, INST_GE, envPtr);
|
||
}
|
||
|
||
int
|
||
TclCompileEqOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr)
|
||
{
|
||
return CompileComparisonOpCmd(interp, parsePtr, INST_EQ, envPtr);
|
||
}
|
||
|
||
int
|
||
TclCompileStreqOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr)
|
||
{
|
||
return CompileComparisonOpCmd(interp, parsePtr, INST_STR_EQ, envPtr);
|
||
}
|
||
|
||
int
|
||
TclCompileMinusOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr)
|
||
{
|
||
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
|
||
DefineLineInformation; /* TIP #280 */
|
||
int words;
|
||
|
||
if (parsePtr->numWords == 1) {
|
||
/* Fallback to direct eval to report syntax error */
|
||
return TCL_ERROR;
|
||
}
|
||
for (words=1 ; words<parsePtr->numWords ; words++) {
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, words);
|
||
}
|
||
if (words == 2) {
|
||
TclEmitOpcode(INST_UMINUS, envPtr);
|
||
return TCL_OK;
|
||
}
|
||
if (words == 3) {
|
||
TclEmitOpcode(INST_SUB, envPtr);
|
||
return TCL_OK;
|
||
}
|
||
/*
|
||
* Reverse order of arguments to get precise agreement with
|
||
* [expr] in calcuations, including roundoff errors.
|
||
*/
|
||
TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
|
||
while (--words > 1) {
|
||
TclEmitInstInt4(INST_REVERSE, 2, envPtr);
|
||
TclEmitOpcode(INST_SUB, envPtr);
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
int
|
||
TclCompileDivOpCmd(
|
||
Tcl_Interp *interp,
|
||
Tcl_Parse *parsePtr,
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr)
|
||
{
|
||
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
|
||
DefineLineInformation; /* TIP #280 */
|
||
int words;
|
||
|
||
if (parsePtr->numWords == 1) {
|
||
/* Fallback to direct eval to report syntax error */
|
||
return TCL_ERROR;
|
||
}
|
||
if (parsePtr->numWords == 2) {
|
||
PushLiteral(envPtr, "1.0", 3);
|
||
}
|
||
for (words=1 ; words<parsePtr->numWords ; words++) {
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, words);
|
||
}
|
||
if (words <= 3) {
|
||
TclEmitOpcode(INST_DIV, envPtr);
|
||
return TCL_OK;
|
||
}
|
||
/*
|
||
* Reverse order of arguments to get precise agreement with
|
||
* [expr] in calcuations, including roundoff errors.
|
||
*/
|
||
TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
|
||
while (--words > 1) {
|
||
TclEmitInstInt4(INST_REVERSE, 2, envPtr);
|
||
TclEmitOpcode(INST_DIV, envPtr);
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* IndexTailVarIfKnown --
|
||
*
|
||
* Procedure used in compiling [global] and [variable] commands. It
|
||
* inspects the variable name described by varTokenPtr and, if the tail
|
||
* is known at compile time, defines a corresponding local variable.
|
||
*
|
||
* Results:
|
||
* Returns the variable's index in the table of compiled locals if the
|
||
* tail is known at compile time, or -1 otherwise.
|
||
*
|
||
* Side effects:
|
||
* None.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
IndexTailVarIfKnown(
|
||
Tcl_Interp *interp,
|
||
Tcl_Token *varTokenPtr, /* Token representing the variable name */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
Tcl_Obj *tailPtr;
|
||
const char *tailName, *p;
|
||
int len, n = varTokenPtr->numComponents;
|
||
Tcl_Token *lastTokenPtr;
|
||
int full, localIndex;
|
||
|
||
/*
|
||
* Determine if the tail is (a) known at compile time, and (b) not an
|
||
* array element. Should any of these fail, return an error so that
|
||
* the non-compiled command will be called at runtime.
|
||
* In order for the tail to be known at compile time, the last token
|
||
* in the word has to be constant and contain "::" if it is not the
|
||
* only one.
|
||
*/
|
||
|
||
if (envPtr->procPtr == NULL) {
|
||
return -1;
|
||
}
|
||
|
||
TclNewObj(tailPtr);
|
||
if (TclWordKnownAtCompileTime(varTokenPtr, tailPtr)) {
|
||
full = 1;
|
||
lastTokenPtr = varTokenPtr;
|
||
} else {
|
||
full = 0;
|
||
lastTokenPtr = varTokenPtr + n;
|
||
if (!TclWordKnownAtCompileTime(lastTokenPtr, tailPtr)) {
|
||
Tcl_DecrRefCount(tailPtr);
|
||
return -1;
|
||
}
|
||
}
|
||
|
||
tailName = TclGetStringFromObj(tailPtr, &len);
|
||
|
||
if (len) {
|
||
if (*(tailName+len-1) == ')') {
|
||
/*
|
||
* Possible array: bail out
|
||
*/
|
||
|
||
Tcl_DecrRefCount(tailPtr);
|
||
return -1;
|
||
}
|
||
|
||
/*
|
||
* Get the tail: immediately after the last '::'
|
||
*/
|
||
|
||
for(p = tailName + len -1; p > tailName; p--) {
|
||
if ((*p == ':') && (*(p-1) == ':')) {
|
||
p++;
|
||
break;
|
||
}
|
||
}
|
||
if (!full && (p == tailName)) {
|
||
/*
|
||
* No :: in the last component
|
||
*/
|
||
Tcl_DecrRefCount(tailPtr);
|
||
return -1;
|
||
}
|
||
len -= p - tailName;
|
||
tailName = p;
|
||
}
|
||
|
||
localIndex = TclFindCompiledLocal(tailName, len,
|
||
/*create*/ TCL_CREATE_VAR,
|
||
envPtr->procPtr);
|
||
Tcl_DecrRefCount(tailPtr);
|
||
return localIndex;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileUpvarCmd --
|
||
*
|
||
* Procedure called to compile the "upvar" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "upvar" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileUpvarCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
|
||
int localIndex, numWords, i;
|
||
DefineLineInformation; /* TIP #280 */
|
||
Tcl_Obj *objPtr;
|
||
|
||
if (envPtr->procPtr == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
numWords = parsePtr->numWords;
|
||
if (numWords < 3) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Push the frame index if it is known at compile time
|
||
*/
|
||
|
||
objPtr = Tcl_NewObj();
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
if(TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
|
||
CallFrame *framePtr;
|
||
Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr;
|
||
|
||
/*
|
||
* Attempt to convert to a level reference. Note that TclObjGetFrame
|
||
* only changes the obj type when a conversion was successful.
|
||
*/
|
||
|
||
TclObjGetFrame(interp, objPtr, &framePtr);
|
||
newTypePtr = objPtr->typePtr;
|
||
Tcl_DecrRefCount(objPtr);
|
||
|
||
if (newTypePtr != typePtr) {
|
||
if(numWords%2) {
|
||
return TCL_ERROR;
|
||
}
|
||
/* TODO: Push the known value instead? */
|
||
CompileWord(envPtr, tokenPtr, interp, 1);
|
||
otherTokenPtr = TokenAfter(tokenPtr);
|
||
i = 2;
|
||
} else {
|
||
if(!(numWords%2)) {
|
||
return TCL_ERROR;
|
||
}
|
||
PushLiteral(envPtr, "1", 1);
|
||
otherTokenPtr = tokenPtr;
|
||
i = 1;
|
||
}
|
||
} else {
|
||
Tcl_DecrRefCount(objPtr);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a
|
||
* local variable, return an error so that the non-compiled command will
|
||
* be called at runtime.
|
||
*/
|
||
|
||
for(; i<numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) {
|
||
localTokenPtr = TokenAfter(otherTokenPtr);
|
||
|
||
CompileWord(envPtr, otherTokenPtr, interp, i);
|
||
localIndex = LocalScalarFromToken(localTokenPtr, envPtr);
|
||
if (localIndex < 0) {
|
||
return TCL_ERROR;
|
||
}
|
||
TclEmitInstInt4(INST_UPVAR, localIndex, envPtr);
|
||
}
|
||
|
||
/*
|
||
* Pop the frame index, and set the result to empty
|
||
*/
|
||
|
||
TclEmitOpcode(INST_POP, envPtr);
|
||
PushLiteral(envPtr, "", 0);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileNamespaceCmd --
|
||
*
|
||
* Procedure called to compile the "namespace" command; currently, only
|
||
* the subcommand "namespace upvar" is compiled to bytecodes.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "namespace upvar"
|
||
* command at runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileNamespaceCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
|
||
int localIndex, numWords, i;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
if (envPtr->procPtr == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Only compile [namespace upvar ...]: needs an odd number of args, >=5
|
||
*/
|
||
|
||
numWords = parsePtr->numWords;
|
||
if (!(numWords%2) || (numWords < 5)) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Check if the second argument is "upvar"
|
||
*/
|
||
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
if ((tokenPtr->size != 5) /* 5 == strlen("upvar") */
|
||
|| strncmp(tokenPtr->start, "upvar", 5)) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Push the namespace
|
||
*/
|
||
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
CompileWord(envPtr, tokenPtr, interp, 2);
|
||
|
||
/*
|
||
* Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a
|
||
* local variable, return an error so that the non-compiled command will
|
||
* be called at runtime.
|
||
*/
|
||
|
||
localTokenPtr = tokenPtr;
|
||
for(i=3; i<numWords; i+=2) {
|
||
otherTokenPtr = TokenAfter(localTokenPtr);
|
||
localTokenPtr = TokenAfter(otherTokenPtr);
|
||
|
||
CompileWord(envPtr, otherTokenPtr, interp, i);
|
||
localIndex = LocalScalarFromToken(localTokenPtr, envPtr);
|
||
if (localIndex < 0) {
|
||
return TCL_ERROR;
|
||
}
|
||
TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr);
|
||
}
|
||
|
||
/*
|
||
* Pop the namespace, and set the result to empty
|
||
*/
|
||
|
||
TclEmitOpcode(INST_POP, envPtr);
|
||
PushLiteral(envPtr, "", 0);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileGlobalCmd --
|
||
*
|
||
* Procedure called to compile the "global" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "global" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileGlobalCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
Tcl_Token *varTokenPtr;
|
||
int localIndex, numWords, i;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
numWords = parsePtr->numWords;
|
||
if (numWords < 2) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* 'global' has no effect outside of proc bodies; handle that at runtime
|
||
*/
|
||
|
||
if (envPtr->procPtr == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Push the namespace
|
||
*/
|
||
|
||
PushLiteral(envPtr, "::", 2);
|
||
|
||
/*
|
||
* Loop over the variables.
|
||
*/
|
||
|
||
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
for(i=1; i<numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) {
|
||
localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
|
||
|
||
if(localIndex < 0) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* TODO: Consider what values can pass through the
|
||
* IndexTailVarIfKnown() screen. Full CompileWord()
|
||
* likely does not apply here. Push known value instead. */
|
||
CompileWord(envPtr, varTokenPtr, interp, i);
|
||
TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr);
|
||
}
|
||
|
||
/*
|
||
* Pop the namespace, and set the result to empty
|
||
*/
|
||
|
||
TclEmitOpcode(INST_POP, envPtr);
|
||
PushLiteral(envPtr, "", 0);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileVariableCmd --
|
||
*
|
||
* Procedure called to compile the "variable" command.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "variable" command at
|
||
* runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileVariableCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
Tcl_Token *varTokenPtr, *valueTokenPtr;
|
||
int localIndex, numWords, i;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
numWords = parsePtr->numWords;
|
||
if (numWords < 2) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Bail out if not compiling a proc body
|
||
*/
|
||
|
||
if (envPtr->procPtr == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Loop over the (var, value) pairs.
|
||
*/
|
||
|
||
valueTokenPtr = parsePtr->tokenPtr;
|
||
for(i=1; i<numWords; i+=2) {
|
||
varTokenPtr = TokenAfter(valueTokenPtr);
|
||
valueTokenPtr = TokenAfter(varTokenPtr);
|
||
|
||
localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
|
||
|
||
if(localIndex < 0) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* TODO: Consider what values can pass through the
|
||
* IndexTailVarIfKnown() screen. Full CompileWord()
|
||
* likely does not apply here. Push known value instead. */
|
||
CompileWord(envPtr, varTokenPtr, interp, i);
|
||
TclEmitInstInt4(INST_VARIABLE, localIndex, envPtr);
|
||
|
||
if (i != numWords-1) {
|
||
/*
|
||
* A value has been given: set the variable, pop the value
|
||
*/
|
||
|
||
CompileWord(envPtr, valueTokenPtr, interp, i+1);
|
||
TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
|
||
TclEmitOpcode(INST_POP, envPtr);
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Set the result to empty
|
||
*/
|
||
|
||
PushLiteral(envPtr, "", 0);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileEnsemble --
|
||
*
|
||
* Procedure called to compile an ensemble command. Note that most
|
||
* ensembles are not compiled, since modifying a compiled ensemble causes
|
||
* a invalidation of all existing bytecode (expensive!) which is not
|
||
* normally warranted.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the subcommands of the
|
||
* ensemble at runtime if a compile-time mapping is possible.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileEnsemble(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
Tcl_Token *tokenPtr;
|
||
Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
|
||
Tcl_Command ensemble = (Tcl_Command) cmdPtr;
|
||
Tcl_Parse synthetic;
|
||
int len, numBytes, result, flags = 0, i;
|
||
const char *word;
|
||
DefineLineInformation;
|
||
|
||
if (parsePtr->numWords < 2) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
|
||
/*
|
||
* Too hard.
|
||
*/
|
||
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
word = tokenPtr[1].start;
|
||
numBytes = tokenPtr[1].size;
|
||
|
||
/*
|
||
* There's a sporting chance we'll be able to compile this. But now we
|
||
* must check properly. To do that, check that we're compiling an ensemble
|
||
* that has a compilable command as its appropriate subcommand.
|
||
*/
|
||
|
||
if (Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj) != TCL_OK
|
||
|| mapObj == NULL) {
|
||
/*
|
||
* Either not an ensemble or a mapping isn't installed. Crud. Too hard
|
||
* to proceed.
|
||
*/
|
||
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Next, get the flags. We need them on several code paths.
|
||
*/
|
||
|
||
(void) Tcl_GetEnsembleFlags(NULL, ensemble, &flags);
|
||
|
||
/*
|
||
* Check to see if there's also a subcommand list; must check to see if
|
||
* the subcommand we are calling is in that list if it exists, since that
|
||
* list filters the entries in the map.
|
||
*/
|
||
|
||
(void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj);
|
||
if (listObj != NULL) {
|
||
int sclen;
|
||
const char *str;
|
||
Tcl_Obj *matchObj = NULL;
|
||
|
||
if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
for (i=0 ; i<len ; i++) {
|
||
str = Tcl_GetStringFromObj(elems[i], &sclen);
|
||
if (sclen==numBytes && !memcmp(word, str, (unsigned) numBytes)) {
|
||
/*
|
||
* Exact match! Excellent!
|
||
*/
|
||
|
||
result = Tcl_DictObjGet(NULL, mapObj,elems[i], &targetCmdObj);
|
||
if (result != TCL_OK || targetCmdObj == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
goto doneMapLookup;
|
||
}
|
||
|
||
/*
|
||
* Check to see if we've got a prefix match. A single prefix match
|
||
* is fine, and allows us to refine our dictionary lookup, but
|
||
* multiple prefix matches is a Bad Thing and will prevent us from
|
||
* making progress. Note that we cannot do the lookup immediately
|
||
* in the prefix case; might be another entry later in the list
|
||
* that causes things to fail.
|
||
*/
|
||
|
||
if ((flags & TCL_ENSEMBLE_PREFIX)
|
||
&& strncmp(word, str, (unsigned) numBytes) == 0) {
|
||
if (matchObj != NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
matchObj = elems[i];
|
||
}
|
||
}
|
||
if (matchObj != NULL) {
|
||
result = Tcl_DictObjGet(NULL, mapObj, matchObj, &targetCmdObj);
|
||
if (result != TCL_OK || targetCmdObj == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
goto doneMapLookup;
|
||
}
|
||
return TCL_ERROR;
|
||
} else {
|
||
/*
|
||
* No map, so check the dictionary directly.
|
||
*/
|
||
|
||
TclNewStringObj(subcmdObj, word, numBytes);
|
||
result = Tcl_DictObjGet(NULL, mapObj, subcmdObj, &targetCmdObj);
|
||
TclDecrRefCount(subcmdObj);
|
||
if (result == TCL_OK && targetCmdObj != NULL) {
|
||
/*
|
||
* Got it. Skip the fiddling around with prefixes.
|
||
*/
|
||
|
||
goto doneMapLookup;
|
||
}
|
||
|
||
/*
|
||
* We've not literally got a valid subcommand. But maybe we have a
|
||
* prefix. Check if prefix matches are allowed.
|
||
*/
|
||
|
||
if (flags & TCL_ENSEMBLE_PREFIX) {
|
||
Tcl_DictSearch s;
|
||
int done, matched;
|
||
Tcl_Obj *tmpObj;
|
||
|
||
/*
|
||
* Iterate over the keys in the dictionary, checking to see if
|
||
* we're a prefix.
|
||
*/
|
||
|
||
Tcl_DictObjFirst(NULL,mapObj,&s,&subcmdObj,&tmpObj,&done);
|
||
matched = 0;
|
||
while (!done) {
|
||
if (strncmp(TclGetString(subcmdObj), word,
|
||
(unsigned) numBytes) == 0) {
|
||
if (matched++) {
|
||
/*
|
||
* Must have matched twice! Not unique, so no point
|
||
* looking further.
|
||
*/
|
||
|
||
break;
|
||
}
|
||
targetCmdObj = tmpObj;
|
||
}
|
||
Tcl_DictObjNext(&s, &subcmdObj, &tmpObj, &done);
|
||
}
|
||
Tcl_DictObjDone(&s);
|
||
|
||
/*
|
||
* If we have anything other than a single match, we've failed the
|
||
* unique prefix check.
|
||
*/
|
||
|
||
if (matched != 1) {
|
||
return TCL_ERROR;
|
||
}
|
||
} else {
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* OK, we definitely map to something. But what?
|
||
*
|
||
* The command we map to is the first word out of the map element. Note
|
||
* that we also reject dealing with multi-element rewrites if we are in a
|
||
* safe interpreter, as there is otherwise a (highly gnarly!) way to make
|
||
* Tcl crash open to exploit.
|
||
*/
|
||
|
||
doneMapLookup:
|
||
if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
if (len > 1 && Tcl_IsSafe(interp)) {
|
||
return TCL_ERROR;
|
||
}
|
||
targetCmdObj = elems[0];
|
||
|
||
Tcl_IncrRefCount(targetCmdObj);
|
||
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj);
|
||
TclDecrRefCount(targetCmdObj);
|
||
if (cmdPtr == NULL || cmdPtr->compileProc == NULL
|
||
|| cmdPtr->flags & CMD_HAS_EXEC_TRACES
|
||
|| ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) {
|
||
/*
|
||
* Maps to an undefined command or a command without a compiler.
|
||
* Cannot compile.
|
||
*/
|
||
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Now we've done the mapping process, can now actually try to compile.
|
||
* We do this by handing off to the subcommand's actual compiler. But to
|
||
* do that, we have to perform some trickery to rewrite the arguments.
|
||
*/
|
||
|
||
TclParseInit(interp, NULL, 0, &synthetic);
|
||
synthetic.numWords = parsePtr->numWords - 2 + len;
|
||
TclGrowParseTokenArray(&synthetic, 2*len);
|
||
synthetic.numTokens = 2*len;
|
||
|
||
/*
|
||
* Now we have the space to work in, install something rewritten. Note
|
||
* that we are here praying for all our might that none of these words are
|
||
* a script; the error detection code will crash if that happens and there
|
||
* is nothing we can do to avoid it!
|
||
*/
|
||
|
||
for (i=0 ; i<len ; i++) {
|
||
int sclen;
|
||
const char *str = Tcl_GetStringFromObj(elems[i], &sclen);
|
||
|
||
synthetic.tokenPtr[2*i].type = TCL_TOKEN_SIMPLE_WORD;
|
||
synthetic.tokenPtr[2*i].start = str;
|
||
synthetic.tokenPtr[2*i].size = sclen;
|
||
synthetic.tokenPtr[2*i].numComponents = 1;
|
||
|
||
synthetic.tokenPtr[2*i+1].type = TCL_TOKEN_TEXT;
|
||
synthetic.tokenPtr[2*i+1].start = str;
|
||
synthetic.tokenPtr[2*i+1].size = sclen;
|
||
synthetic.tokenPtr[2*i+1].numComponents = 0;
|
||
}
|
||
|
||
/*
|
||
* Copy over the real argument tokens.
|
||
*/
|
||
|
||
for (i=len; i<synthetic.numWords; i++) {
|
||
int toCopy;
|
||
tokenPtr = TokenAfter(tokenPtr);
|
||
toCopy = tokenPtr->numComponents + 1;
|
||
TclGrowParseTokenArray(&synthetic, toCopy);
|
||
memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr,
|
||
sizeof(Tcl_Token) * toCopy);
|
||
synthetic.numTokens += toCopy;
|
||
}
|
||
|
||
/*
|
||
* Hand off compilation to the subcommand compiler. At last!
|
||
*/
|
||
|
||
mapPtr->loc[eclIndex].line++;
|
||
mapPtr->loc[eclIndex].next++;
|
||
|
||
result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr);
|
||
|
||
mapPtr->loc[eclIndex].line--;
|
||
mapPtr->loc[eclIndex].next--;
|
||
|
||
/*
|
||
* Clean up if necessary.
|
||
*/
|
||
|
||
Tcl_FreeParse(&synthetic);
|
||
return result;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclCompileInfoExistsCmd --
|
||
*
|
||
* Procedure called to compile the "info exists" subcommand.
|
||
*
|
||
* Results:
|
||
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
|
||
* evaluation to runtime.
|
||
*
|
||
* Side effects:
|
||
* Instructions are added to envPtr to execute the "info exists"
|
||
* subcommand at runtime.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
TclCompileInfoExistsCmd(
|
||
Tcl_Interp *interp, /* Used for error reporting. */
|
||
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
|
||
* created by Tcl_ParseCommand. */
|
||
Command *cmdPtr, /* Points to defintion of command being
|
||
* compiled. */
|
||
CompileEnv *envPtr) /* Holds resulting instructions. */
|
||
{
|
||
Tcl_Token *tokenPtr;
|
||
int isScalar, simpleVarName, localIndex;
|
||
DefineLineInformation; /* TIP #280 */
|
||
|
||
if (parsePtr->numWords != 2) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Decide if we can use a frame slot for the var/array name or if we need
|
||
* to emit code to compute and push the name at runtime. We use a frame
|
||
* slot (entry in the array of local vars) if we are compiling a procedure
|
||
* body and if the name is simple text that does not include namespace
|
||
* qualifiers.
|
||
*/
|
||
|
||
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
||
PushVarNameWord(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex,
|
||
&simpleVarName, &isScalar, 1);
|
||
|
||
/*
|
||
* Emit instruction to check the variable for existence.
|
||
*/
|
||
|
||
if (simpleVarName) {
|
||
if (isScalar) {
|
||
if (localIndex < 0) {
|
||
TclEmitOpcode(INST_EXIST_STK, envPtr);
|
||
} else {
|
||
TclEmitInstInt4(INST_EXIST_SCALAR, localIndex, envPtr);
|
||
}
|
||
} else {
|
||
if (localIndex < 0) {
|
||
TclEmitOpcode(INST_EXIST_ARRAY_STK, envPtr);
|
||
} else {
|
||
TclEmitInstInt4(INST_EXIST_ARRAY, localIndex, envPtr);
|
||
}
|
||
}
|
||
} else {
|
||
TclEmitOpcode(INST_EXIST_STK, envPtr);
|
||
}
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* Local Variables:
|
||
* mode: c
|
||
* c-basic-offset: 4
|
||
* fill-column: 78
|
||
* End:
|
||
*/
|