riscv
/
OpenFPGA
mirror of https://github.com/lnis-uofu/OpenFPGA.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity
OpenFPGA/libs/EXTERNAL/tcl8.6.12/generic/tclCompCmdsSZ.c

4533 lines
124 KiB
C
Raw Normal View History

adding Tcl interface to vpr
2022-06-07 11:15:20 -05:00
/*
* tclCompCmdsSZ.c --
*
* This file contains compilation procedures that compile various Tcl
* commands (beginning with the letters 's' through 'z', except for
* [upvar] and [variable]) into a sequence of instructions ("bytecodes").
* Also includes the operator command compilers.
*
* 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-2010 by Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclCompile.h"
#include "tclStringTrim.h"
/*
* Prototypes for procedures defined later in this file:
*/
static ClientData DupJumptableInfo(ClientData clientData);
static void FreeJumptableInfo(ClientData clientData);
static void PrintJumptableInfo(ClientData clientData,
Tcl_Obj *appendObj, ByteCode *codePtr,
unsigned int pcOffset);
static void DisassembleJumptableInfo(ClientData clientData,
Tcl_Obj *dictObj, ByteCode *codePtr,
unsigned int pcOffset);
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 IssueSwitchChainedTests(Tcl_Interp *interp,
CompileEnv *envPtr, int mode, int noCase,
int valueIndex, int numWords,
Tcl_Token **bodyToken, int *bodyLines,
int **bodyNext);
static void IssueSwitchJumpTable(Tcl_Interp *interp,
CompileEnv *envPtr, int valueIndex,
int numWords, Tcl_Token **bodyToken,
int *bodyLines, int **bodyContLines);
static int IssueTryClausesInstructions(Tcl_Interp *interp,
CompileEnv *envPtr, Tcl_Token *bodyToken,
int numHandlers, int *matchCodes,
Tcl_Obj **matchClauses, int *resultVarIndices,
int *optionVarIndices, Tcl_Token **handlerTokens);
static int IssueTryClausesFinallyInstructions(Tcl_Interp *interp,
CompileEnv *envPtr, Tcl_Token *bodyToken,
int numHandlers, int *matchCodes,
Tcl_Obj **matchClauses, int *resultVarIndices,
int *optionVarIndices, Tcl_Token **handlerTokens,
Tcl_Token *finallyToken);
static int IssueTryFinallyInstructions(Tcl_Interp *interp,
CompileEnv *envPtr, Tcl_Token *bodyToken,
Tcl_Token *finallyToken);
/*
* The structures below define the AuxData types defined in this file.
*/
const AuxDataType tclJumptableInfoType = {
"JumptableInfo", /* name */
DupJumptableInfo, /* dupProc */
FreeJumptableInfo, /* freeProc */
PrintJumptableInfo, /* printProc */
DisassembleJumptableInfo /* disassembleProc */
};
/*
* Shorthand macros for instruction issuing.
*/
#define OP(name) TclEmitOpcode(INST_##name, envPtr)
#define OP1(name,val) TclEmitInstInt1(INST_##name,(val),envPtr)
#define OP4(name,val) TclEmitInstInt4(INST_##name,(val),envPtr)
#define OP14(name,val1,val2) \
TclEmitInstInt1(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr)
#define OP44(name,val1,val2) \
TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr)
#define PUSH(str) \
PushStringLiteral(envPtr, str)
#define JUMP4(name,var) \
(var) = CurrentOffset(envPtr);TclEmitInstInt4(INST_##name##4,0,envPtr)
#define FIXJUMP4(var) \
TclStoreInt4AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1)
#define JUMP1(name,var) \
(var) = CurrentOffset(envPtr);TclEmitInstInt1(INST_##name##1,0,envPtr)
#define FIXJUMP1(var) \
TclStoreInt1AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1)
#define LOAD(idx) \
if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));}
#define STORE(idx) \
if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));}
#define INVOKE(name) \
TclEmitInvoke(envPtr,INST_##name)
/*
*----------------------------------------------------------------------
*
* 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. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *valueTokenPtr;
int isAssignment, isScalar, localIndex, numWords;
numWords = parsePtr->numWords;
if ((numWords != 2) && (numWords != 3)) {
return TCL_ERROR;
}
isAssignment = (numWords == 3);
/*
* Decide if we can use a frame slot for the var/array name or if we need
* to emit code to compute and push the name at runtime. We use a frame
* slot (entry in the array of local vars) if we are compiling a procedure
* body and if the name is simple text that does not include namespace
* qualifiers.
*/
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
PushVarNameWord(interp, varTokenPtr, envPtr, 0,
&localIndex, &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 (isScalar) {
if (localIndex < 0) {
TclEmitOpcode((isAssignment?
INST_STORE_STK : INST_LOAD_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);
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileString*Cmd --
*
* Procedures called to compile various subcommands of the "string"
* 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" command at
* runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileStringCatCmd(
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 */
int i, numWords = parsePtr->numWords, numArgs;
Tcl_Token *wordTokenPtr;
Tcl_Obj *obj, *folded;
/* Trivial case, no arg */
if (numWords<2) {
PushStringLiteral(envPtr, "");
return TCL_OK;
}
/* General case: issue CONCAT1's (by chunks of 254 if needed), folding
contiguous constants along the way */
numArgs = 0;
folded = NULL;
wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
for (i = 1; i < numWords; i++) {
obj = Tcl_NewObj();
if (TclWordKnownAtCompileTime(wordTokenPtr, obj)) {
if (folded) {
Tcl_AppendObjToObj(folded, obj);
Tcl_DecrRefCount(obj);
} else {
folded = obj;
}
} else {
Tcl_DecrRefCount(obj);
if (folded) {
int len;
const char *bytes = Tcl_GetStringFromObj(folded, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(folded);
folded = NULL;
numArgs ++;
}
CompileWord(envPtr, wordTokenPtr, interp, i);
numArgs ++;
if (numArgs >= 254) { /* 254 to take care of the possible +1 of "folded" above */
TclEmitInstInt1(INST_STR_CONCAT1, numArgs, envPtr);
numArgs = 1; /* concat pushes 1 obj, the result */
}
}
wordTokenPtr = TokenAfter(wordTokenPtr);
}
if (folded) {
int len;
const char *bytes = Tcl_GetStringFromObj(folded, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(folded);
folded = NULL;
numArgs ++;
}
if (numArgs > 1) {
TclEmitInstInt1(INST_STR_CONCAT1, numArgs, envPtr);
}
return TCL_OK;
}
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;
}
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;
}
int
TclCompileStringFirstCmd(
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);
OP(STR_FIND);
return TCL_OK;
}
int
TclCompileStringLastCmd(
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);
OP(STR_FIND_LAST);
return TCL_OK;
}
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;
}
int
TclCompileStringIsCmd(
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 = TokenAfter(parsePtr->tokenPtr);
static const char *const isClasses[] = {
"alnum", "alpha", "ascii", "control",
"boolean", "digit", "double", "entier",
"false", "graph", "integer", "list",
"lower", "print", "punct", "space",
"true", "upper", "wideinteger", "wordchar",
"xdigit", NULL
};
enum isClasses {
STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER,
STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST,
STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE,
STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD,
STR_IS_XDIGIT
};
int t, range, allowEmpty = 0, end;
InstStringClassType strClassType;
Tcl_Obj *isClass;
if (parsePtr->numWords < 3 || parsePtr->numWords > 6) {
return TCL_ERROR;
}
isClass = Tcl_NewObj();
if (!TclWordKnownAtCompileTime(tokenPtr, isClass)) {
Tcl_DecrRefCount(isClass);
return TCL_ERROR;
} else if (Tcl_GetIndexFromObj(interp, isClass, isClasses, "class", 0,
&t) != TCL_OK) {
Tcl_DecrRefCount(isClass);
TclCompileSyntaxError(interp, envPtr);
return TCL_OK;
}
Tcl_DecrRefCount(isClass);
#define GotLiteral(tokenPtr, word) \
((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD && \
(tokenPtr)[1].size > 1 && \
(tokenPtr)[1].start[0] == word[0] && \
strncmp((tokenPtr)[1].start, (word), (tokenPtr)[1].size) == 0)
/*
* Cannot handle the -failindex option at all, and that's the only legal
* way to have more than 4 arguments.
*/
if (parsePtr->numWords != 3 && parsePtr->numWords != 4) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(tokenPtr);
if (parsePtr->numWords == 3) {
allowEmpty = 1;
} else {
if (!GotLiteral(tokenPtr, "-strict")) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(tokenPtr);
}
#undef GotLiteral
/*
* Compile the code. There are several main classes of check here.
* 1. Character classes
* 2. Booleans
* 3. Integers
* 4. Floats
* 5. Lists
*/
CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1);
switch ((enum isClasses) t) {
case STR_IS_ALNUM:
strClassType = STR_CLASS_ALNUM;
goto compileStrClass;
case STR_IS_ALPHA:
strClassType = STR_CLASS_ALPHA;
goto compileStrClass;
case STR_IS_ASCII:
strClassType = STR_CLASS_ASCII;
goto compileStrClass;
case STR_IS_CONTROL:
strClassType = STR_CLASS_CONTROL;
goto compileStrClass;
case STR_IS_DIGIT:
strClassType = STR_CLASS_DIGIT;
goto compileStrClass;
case STR_IS_GRAPH:
strClassType = STR_CLASS_GRAPH;
goto compileStrClass;
case STR_IS_LOWER:
strClassType = STR_CLASS_LOWER;
goto compileStrClass;
case STR_IS_PRINT:
strClassType = STR_CLASS_PRINT;
goto compileStrClass;
case STR_IS_PUNCT:
strClassType = STR_CLASS_PUNCT;
goto compileStrClass;
case STR_IS_SPACE:
strClassType = STR_CLASS_SPACE;
goto compileStrClass;
case STR_IS_UPPER:
strClassType = STR_CLASS_UPPER;
goto compileStrClass;
case STR_IS_WORD:
strClassType = STR_CLASS_WORD;
goto compileStrClass;
case STR_IS_XDIGIT:
strClassType = STR_CLASS_XDIGIT;
compileStrClass:
if (allowEmpty) {
OP1( STR_CLASS, strClassType);
} else {
int over, over2;
OP( DUP);
OP1( STR_CLASS, strClassType);
JUMP1( JUMP_TRUE, over);
OP( POP);
PUSH( "0");
JUMP1( JUMP, over2);
FIXJUMP1(over);
PUSH( "");
OP( STR_NEQ);
FIXJUMP1(over2);
}
return TCL_OK;
case STR_IS_BOOL:
case STR_IS_FALSE:
case STR_IS_TRUE:
OP( TRY_CVT_TO_BOOLEAN);
switch (t) {
int over, over2;
case STR_IS_BOOL:
if (allowEmpty) {
JUMP1( JUMP_TRUE, over);
PUSH( "");
OP( STR_EQ);
JUMP1( JUMP, over2);
FIXJUMP1(over);
OP( POP);
PUSH( "1");
FIXJUMP1(over2);
} else {
OP4( REVERSE, 2);
OP( POP);
}
return TCL_OK;
case STR_IS_TRUE:
JUMP1( JUMP_TRUE, over);
if (allowEmpty) {
PUSH( "");
OP( STR_EQ);
} else {
OP( POP);
PUSH( "0");
}
FIXJUMP1( over);
OP( LNOT);
OP( LNOT);
return TCL_OK;
case STR_IS_FALSE:
JUMP1( JUMP_TRUE, over);
if (allowEmpty) {
PUSH( "");
OP( STR_NEQ);
} else {
OP( POP);
PUSH( "1");
}
FIXJUMP1( over);
OP( LNOT);
return TCL_OK;
}
break;
case STR_IS_DOUBLE: {
int satisfied, isEmpty;
if (allowEmpty) {
OP( DUP);
PUSH( "");
OP( STR_EQ);
JUMP1( JUMP_TRUE, isEmpty);
OP( NUM_TYPE);
JUMP1( JUMP_TRUE, satisfied);
PUSH( "0");
JUMP1( JUMP, end);
FIXJUMP1( isEmpty);
OP( POP);
FIXJUMP1( satisfied);
} else {
OP( NUM_TYPE);
JUMP1( JUMP_TRUE, satisfied);
PUSH( "0");
JUMP1( JUMP, end);
TclAdjustStackDepth(-1, envPtr);
FIXJUMP1( satisfied);
}
PUSH( "1");
FIXJUMP1( end);
return TCL_OK;
}
case STR_IS_INT:
case STR_IS_WIDE:
case STR_IS_ENTIER:
if (allowEmpty) {
int testNumType;
OP( DUP);
OP( NUM_TYPE);
OP( DUP);
JUMP1( JUMP_TRUE, testNumType);
OP( POP);
PUSH( "");
OP( STR_EQ);
JUMP1( JUMP, end);
TclAdjustStackDepth(1, envPtr);
FIXJUMP1( testNumType);
OP4( REVERSE, 2);
OP( POP);
} else {
OP( NUM_TYPE);
OP( DUP);
JUMP1( JUMP_FALSE, end);
}
switch (t) {
case STR_IS_INT:
PUSH( "1");
OP( EQ);
break;
case STR_IS_WIDE:
PUSH( "2");
OP( LE);
break;
case STR_IS_ENTIER:
PUSH( "3");
OP( LE);
break;
}
FIXJUMP1( end);
return TCL_OK;
case STR_IS_LIST:
range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
OP4( BEGIN_CATCH4, range);
ExceptionRangeStarts(envPtr, range);
OP( DUP);
OP( LIST_LENGTH);
OP( POP);
ExceptionRangeEnds(envPtr, range);
ExceptionRangeTarget(envPtr, range, catchOffset);
OP( POP);
OP( PUSH_RETURN_CODE);
OP( END_CATCH);
OP( LNOT);
return TCL_OK;
}
return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
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 TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
str = tokenPtr[1].start;
length = tokenPtr[1].size;
if ((length <= 1) || strncmp(str, "-nocase", length)) {
/*
* Fail at run time, not in compilation.
*/
return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
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;
}
int
TclCompileStringLenCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
Tcl_Obj *objPtr;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
TclNewObj(objPtr);
if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
/*
* Here someone is asking for the length of a static string (or
* something with backslashes). Just push the actual character (not
* byte) length.
*/
char buf[TCL_INTEGER_SPACE];
int len = Tcl_GetCharLength(objPtr);
len = sprintf(buf, "%d", len);
PushLiteral(envPtr, buf, len);
} else {
SetLineInformation(1);
CompileTokens(envPtr, tokenPtr, interp);
TclEmitOpcode(INST_STR_LEN, envPtr);
}
TclDecrRefCount(objPtr);
return TCL_OK;
}
int
TclCompileStringMapCmd(
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 *mapTokenPtr, *stringTokenPtr;
Tcl_Obj *mapObj, **objv;
char *bytes;
int len;
/*
* We only handle the case:
*
* string map {foo bar} $thing
*
* That is, a literal two-element list (doesn't need to be brace-quoted,
* but does need to be compile-time knowable) and any old argument (the
* thing to map).
*/
if (parsePtr->numWords != 3) {
return TCL_ERROR;
}
mapTokenPtr = TokenAfter(parsePtr->tokenPtr);
stringTokenPtr = TokenAfter(mapTokenPtr);
mapObj = Tcl_NewObj();
Tcl_IncrRefCount(mapObj);
if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) {
Tcl_DecrRefCount(mapObj);
return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
} else if (Tcl_ListObjGetElements(NULL, mapObj, &len, &objv) != TCL_OK) {
Tcl_DecrRefCount(mapObj);
return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
} else if (len != 2) {
Tcl_DecrRefCount(mapObj);
return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
/*
* Now issue the opcodes. Note that in the case that we know that the
* first word is an empty word, we don't issue the map at all. That is the
* correct semantics for mapping.
*/
bytes = Tcl_GetStringFromObj(objv[0], &len);
if (len == 0) {
CompileWord(envPtr, stringTokenPtr, interp, 2);
} else {
PushLiteral(envPtr, bytes, len);
bytes = Tcl_GetStringFromObj(objv[1], &len);
PushLiteral(envPtr, bytes, len);
CompileWord(envPtr, stringTokenPtr, interp, 2);
OP(STR_MAP);
}
Tcl_DecrRefCount(mapObj);
return TCL_OK;
}
int
TclCompileStringRangeCmd(
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 *stringTokenPtr, *fromTokenPtr, *toTokenPtr;
int idx1, idx2;
if (parsePtr->numWords != 4) {
return TCL_ERROR;
}
stringTokenPtr = TokenAfter(parsePtr->tokenPtr);
fromTokenPtr = TokenAfter(stringTokenPtr);
toTokenPtr = TokenAfter(fromTokenPtr);
/* Every path must push the string argument */
CompileWord(envPtr, stringTokenPtr, interp, 1);
/*
* Parse the two indices.
*/
if (TclGetIndexFromToken(fromTokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER,
&idx1) != TCL_OK) {
goto nonConstantIndices;
}
/*
* Token parsed as an index expression. We treat all indices before
* the string the same as the start of the string.
*/
if (idx1 == TCL_INDEX_AFTER) {
/* [string range $s end+1 $last] must be empty string */
OP( POP);
PUSH( "");
return TCL_OK;
}
if (TclGetIndexFromToken(toTokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END,
&idx2) != TCL_OK) {
goto nonConstantIndices;
}
/*
* Token parsed as an index expression. We treat all indices after
* the string the same as the end of the string.
*/
if (idx2 == TCL_INDEX_BEFORE) {
/* [string range $s $first -1] must be empty string */
OP( POP);
PUSH( "");
return TCL_OK;
}
/*
* Push the operand onto the stack and then the substring operation.
*/
OP44( STR_RANGE_IMM, idx1, idx2);
return TCL_OK;
/*
* Push the operands onto the stack and then the substring operation.
*/
nonConstantIndices:
CompileWord(envPtr, fromTokenPtr, interp, 2);
CompileWord(envPtr, toTokenPtr, interp, 3);
OP( STR_RANGE);
return TCL_OK;
}
int
TclCompileStringReplaceCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
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. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *valueTokenPtr;
int first, last;
if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
return TCL_ERROR;
}
/* Bytecode to compute/push string argument being replaced */
valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, valueTokenPtr, interp, 1);
/*
* Check for first index known and useful at compile time.
*/
tokenPtr = TokenAfter(valueTokenPtr);
if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER,
&first) != TCL_OK) {
goto genericReplace;
}
/*
* Check for last index known and useful at compile time.
*/
tokenPtr = TokenAfter(tokenPtr);
if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER,
&last) != TCL_OK) {
goto genericReplace;
}
/*
* [string replace] is an odd bird. For many arguments it is
* a conventional substring replacer. However it also goes out
* of its way to become a no-op for many cases where it would be
* replacing an empty substring. Precisely, it is a no-op when
*
* (last < first) OR
* (last < 0) OR
* (end < first)
*
* For some compile-time values we can detect these cases, and
* compile direct to bytecode implementing the no-op.
*/
if ((last == TCL_INDEX_BEFORE) /* Know (last < 0) */
|| (first == TCL_INDEX_AFTER) /* Know (first > end) */
/*
* Tricky to determine when runtime (last < first) can be
* certainly known based on the encoded values. Consider the
* cases...
*
* (first <= TCL_INDEX_END) &&
* (last == TCL_INDEX_AFTER) => cannot tell REJECT
* (last <= TCL_INDEX END) && (last < first) => ACCEPT
* else => cannot tell REJECT
*/
|| ((first <= TCL_INDEX_END) && (last <= TCL_INDEX_END)
&& (last < first)) /* Know (last < first) */
/*
* (first == TCL_INDEX_BEFORE) &&
* (last == TCL_INDEX_AFTER) => (first < last) REJECT
* (last <= TCL_INDEX_END) => cannot tell REJECT
* else => (first < last) REJECT
*
* else [[first >= TCL_INDEX_START]] &&
* (last == TCL_INDEX_AFTER) => cannot tell REJECT
* (last <= TCL_INDEX_END) => cannot tell REJECT
* else [[last >= TCL_INDEX START]] && (last < first) => ACCEPT
*/
|| ((first >= TCL_INDEX_START) && (last >= TCL_INDEX_START)
&& (last < first))) { /* Know (last < first) */
if (parsePtr->numWords == 5) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 4);
OP( POP); /* Pop newString */
}
/* Original string argument now on TOS as result */
return TCL_OK;
}
if (parsePtr->numWords == 5) {
/*
* When we have a string replacement, we have to take care about
* not replacing empty substrings that [string replace] promises
* not to replace
*
* The remaining index values might be suitable for conventional
* string replacement, but only if they cannot possibly meet the
* conditions described above at runtime. If there's a chance they
* might, we would have to emit bytecode to check and at that point
* we're paying more in bytecode execution time than would make
* things worthwhile. Trouble is we are very limited in
* how much we can detect that at compile time. After decoding,
* we need, first:
*
* (first <= end)
*
* The encoded indices (first <= TCL_INDEX END) and
* (first == TCL_INDEX_BEFORE) always meets this condition, but
* any other encoded first index has some list for which it fails.
*
* We also need, second:
*
* (last >= 0)
*
* The encoded indices (last >= TCL_INDEX_START) and
* (last == TCL_INDEX_AFTER) always meet this condition but any
* other encoded last index has some list for which it fails.
*
* Finally we need, third:
*
* (first <= last)
*
* Considered in combination with the constraints we already have,
* we see that we can proceed when (first == TCL_INDEX_BEFORE)
* or (last == TCL_INDEX_AFTER). These also permit simplification
* of the prefix|replace|suffix construction. The other constraints,
* though, interfere with getting a guarantee that first <= last.
*/
if ((first == TCL_INDEX_BEFORE) && (last >= TCL_INDEX_START)) {
/* empty prefix */
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 4);
OP4( REVERSE, 2);
if (last == TCL_INDEX_AFTER) {
OP( POP); /* Pop original */
} else {
OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END);
OP1( STR_CONCAT1, 2);
}
return TCL_OK;
}
if ((last == TCL_INDEX_AFTER) && (first <= TCL_INDEX_END)) {
OP44( STR_RANGE_IMM, 0, first-1);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 4);
OP1( STR_CONCAT1, 2);
return TCL_OK;
}
/* FLOW THROUGH TO genericReplace */
} else {
/*
* When we have no replacement string to worry about, we may
* have more luck, because the forbidden empty string replacements
* are harmless when they are replaced by another empty string.
*/
if ((first == TCL_INDEX_BEFORE) || (first == TCL_INDEX_START)) {
/* empty prefix - build suffix only */
if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) {
/* empty suffix too => empty result */
OP( POP); /* Pop original */
PUSH ( "");
return TCL_OK;
}
OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END);
return TCL_OK;
} else {
if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) {
/* empty suffix - build prefix only */
OP44( STR_RANGE_IMM, 0, first-1);
return TCL_OK;
}
OP( DUP);
OP44( STR_RANGE_IMM, 0, first-1);
OP4( REVERSE, 2);
OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END);
OP1( STR_CONCAT1, 2);
return TCL_OK;
}
}
genericReplace:
tokenPtr = TokenAfter(valueTokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 3);
if (parsePtr->numWords == 5) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 4);
} else {
PUSH( "");
}
OP( STR_REPLACE);
return TCL_OK;
}
int
TclCompileStringTrimLCmd(
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 && parsePtr->numWords != 3) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
if (parsePtr->numWords == 3) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
} else {
PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet));
}
OP( STR_TRIM_LEFT);
return TCL_OK;
}
int
TclCompileStringTrimRCmd(
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 && parsePtr->numWords != 3) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
if (parsePtr->numWords == 3) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
} else {
PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet));
}
OP( STR_TRIM_RIGHT);
return TCL_OK;
}
int
TclCompileStringTrimCmd(
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 && parsePtr->numWords != 3) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
if (parsePtr->numWords == 3) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
} else {
PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet));
}
OP( STR_TRIM);
return TCL_OK;
}
int
TclCompileStringToUpperCmd(
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 TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
OP( STR_UPPER);
return TCL_OK;
}
int
TclCompileStringToLowerCmd(
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 TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
OP( STR_LOWER);
return TCL_OK;
}
int
TclCompileStringToTitleCmd(
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 TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
OP( STR_TITLE);
return TCL_OK;
}
/*
* Support definitions for the [string is] compilation.
*/
static int
UniCharIsAscii(
int character)
{
return (character >= 0) && (character < 0x80);
}
static int
UniCharIsHexDigit(
int character)
{
return (character >= 0) && (character < 0x80) && isxdigit(character);
}
StringClassDesc const tclStringClassTable[] = {
{"alnum", Tcl_UniCharIsAlnum},
{"alpha", Tcl_UniCharIsAlpha},
{"ascii", UniCharIsAscii},
{"control", Tcl_UniCharIsControl},
{"digit", Tcl_UniCharIsDigit},
{"graph", Tcl_UniCharIsGraph},
{"lower", Tcl_UniCharIsLower},
{"print", Tcl_UniCharIsPrint},
{"punct", Tcl_UniCharIsPunct},
{"space", Tcl_UniCharIsSpace},
{"upper", Tcl_UniCharIsUpper},
{"word", Tcl_UniCharIsWordChar},
{"xdigit", UniCharIsHexDigit},
{NULL, NULL}
};
/*
*----------------------------------------------------------------------
*
* TclCompileSubstCmd --
*
* Procedure called to compile the "subst" command.
*
* Results:
* Returns TCL_OK for successful compile, or TCL_ERROR to defer
* evaluation to runtime (either when it is too complex to get the
* semantics right, or when we know for sure that it is an error but need
* the error to happen at the right time).
*
* Side effects:
* Instructions are added to envPtr to execute the "subst" command at
* runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileSubstCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
int numArgs = parsePtr->numWords - 1;
int numOpts = numArgs - 1;
int objc, flags = TCL_SUBST_ALL;
Tcl_Obj **objv/*, *toSubst = NULL*/;
Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
int code = TCL_ERROR;
if (numArgs == 0) {
return TCL_ERROR;
}
objv = TclStackAlloc(interp, /*numArgs*/ numOpts * sizeof(Tcl_Obj *));
for (objc = 0; objc < /*numArgs*/ numOpts; objc++) {
objv[objc] = Tcl_NewObj();
Tcl_IncrRefCount(objv[objc]);
if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
objc++;
goto cleanup;
}
wordTokenPtr = TokenAfter(wordTokenPtr);
}
/*
if (TclSubstOptions(NULL, numOpts, objv, &flags) == TCL_OK) {
toSubst = objv[numOpts];
Tcl_IncrRefCount(toSubst);
}
*/
/* TODO: Figure out expansion to cover WordKnownAtCompileTime
* The difficulty is that WKACT makes a copy, and if TclSubstParse
* below parses the copy of the original source string, some deep
* parts of the compile machinery get upset. They want all pointers
* stored in Tcl_Tokens to point back to the same original string.
*/
if (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
code = TclSubstOptions(NULL, numOpts, objv, &flags);
}
cleanup:
while (--objc >= 0) {
TclDecrRefCount(objv[objc]);
}
TclStackFree(interp, objv);
if (/*toSubst == NULL*/ code != TCL_OK) {
return TCL_ERROR;
}
SetLineInformation(numArgs);
TclSubstCompile(interp, wordTokenPtr[1].start, wordTokenPtr[1].size,
flags, mapPtr->loc[eclIndex].line[numArgs], envPtr);
/* TclDecrRefCount(toSubst);*/
return TCL_OK;
}
void
TclSubstCompile(
Tcl_Interp *interp,
const char *bytes,
int numBytes,
int flags,
int line,
CompileEnv *envPtr)
{
Tcl_Token *endTokenPtr, *tokenPtr;
int breakOffset = 0, count = 0, bline = line;
Tcl_Parse parse;
Tcl_InterpState state = NULL;
TclSubstParse(interp, bytes, numBytes, flags, &parse, &state);
if (state != NULL) {
Tcl_ResetResult(interp);
}
/*
* Tricky point! If the first token does not result in a *guaranteed* push
* of a Tcl_Obj on the stack, we must push an empty object. Otherwise it
* is possible to get to an INST_STR_CONCAT1 or INST_DONE without enough
* values on the stack, resulting in a crash. Thanks to Joe Mistachkin for
* identifying a script that could trigger this case.
*/
tokenPtr = parse.tokenPtr;
if (tokenPtr->type != TCL_TOKEN_TEXT && tokenPtr->type != TCL_TOKEN_BS) {
PUSH("");
count++;
}
for (endTokenPtr = tokenPtr + parse.numTokens;
tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) {
int length, literal, catchRange, breakJump;
char buf[TCL_UTF_MAX] = "";
JumpFixup startFixup, okFixup, returnFixup, breakFixup;
JumpFixup continueFixup, otherFixup, endFixup;
switch (tokenPtr->type) {
case TCL_TOKEN_TEXT:
literal = TclRegisterNewLiteral(envPtr,
tokenPtr->start, tokenPtr->size);
TclEmitPush(literal, envPtr);
TclAdvanceLines(&bline, tokenPtr->start,
tokenPtr->start + tokenPtr->size);
count++;
continue;
case TCL_TOKEN_BS:
length = TclParseBackslash(tokenPtr->start, tokenPtr->size,
NULL, buf);
literal = TclRegisterNewLiteral(envPtr, buf, length);
TclEmitPush(literal, envPtr);
count++;
continue;
case TCL_TOKEN_VARIABLE:
/*
* Check for simple variable access; see if we can only generate
* TCL_OK or TCL_ERROR from the substituted variable read; if so,
* there is no need to generate elaborate exception-management
* code. Note that the first component of TCL_TOKEN_VARIABLE is
* always TCL_TOKEN_TEXT...
*/
if (tokenPtr->numComponents > 1) {
int i, foundCommand = 0;
for (i=2 ; i<=tokenPtr->numComponents ; i++) {
if (tokenPtr[i].type == TCL_TOKEN_COMMAND) {
foundCommand = 1;
break;
}
}
if (foundCommand) {
break;
}
}
envPtr->line = bline;
TclCompileVarSubst(interp, tokenPtr, envPtr);
bline = envPtr->line;
count++;
continue;
}
while (count > 255) {
OP1( STR_CONCAT1, 255);
count -= 254;
}
if (count > 1) {
OP1( STR_CONCAT1, count);
count = 1;
}
if (breakOffset == 0) {
/* Jump to the start (jump over the jump to end) */
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &startFixup);
/* Jump to the end (all BREAKs land here) */
breakOffset = CurrentOffset(envPtr);
TclEmitInstInt4(INST_JUMP4, 0, envPtr);
/* Start */
if (TclFixupForwardJumpToHere(envPtr, &startFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad start jump distance %d",
(int) (CurrentOffset(envPtr) - startFixup.codeOffset));
}
}
envPtr->line = bline;
catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
OP4( BEGIN_CATCH4, catchRange);
ExceptionRangeStarts(envPtr, catchRange);
switch (tokenPtr->type) {
case TCL_TOKEN_COMMAND:
TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2,
envPtr);
count++;
break;
case TCL_TOKEN_VARIABLE:
TclCompileVarSubst(interp, tokenPtr, envPtr);
count++;
break;
default:
Tcl_Panic("unexpected token type in TclCompileSubstCmd: %d",
tokenPtr->type);
}
ExceptionRangeEnds(envPtr, catchRange);
/* Substitution produced TCL_OK */
OP( END_CATCH);
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &okFixup);
TclAdjustStackDepth(-1, envPtr);
/* Exceptional return codes processed here */
ExceptionRangeTarget(envPtr, catchRange, catchOffset);
OP( PUSH_RETURN_OPTIONS);
OP( PUSH_RESULT);
OP( PUSH_RETURN_CODE);
OP( END_CATCH);
OP( RETURN_CODE_BRANCH);
/* ERROR -> reraise it; NB: can't require BREAK/CONTINUE handling */
OP( RETURN_STK);
OP( NOP);
/* RETURN */
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &returnFixup);
/* BREAK */
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &breakFixup);
/* CONTINUE */
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &continueFixup);
/* OTHER */
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &otherFixup);
TclAdjustStackDepth(1, envPtr);
/* BREAK destination */
if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d",
(int) (CurrentOffset(envPtr) - breakFixup.codeOffset));
}
OP( POP);
OP( POP);
breakJump = CurrentOffset(envPtr) - breakOffset;
if (breakJump > 127) {
OP4(JUMP4, -breakJump);
} else {
OP1(JUMP1, -breakJump);
}
TclAdjustStackDepth(2, envPtr);
/* CONTINUE destination */
if (TclFixupForwardJumpToHere(envPtr, &continueFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d",
(int) (CurrentOffset(envPtr) - continueFixup.codeOffset));
}
OP( POP);
OP( POP);
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup);
TclAdjustStackDepth(2, envPtr);
/* RETURN + other destination */
if (TclFixupForwardJumpToHere(envPtr, &returnFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad return jump distance %d",
(int) (CurrentOffset(envPtr) - returnFixup.codeOffset));
}
if (TclFixupForwardJumpToHere(envPtr, &otherFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad other jump distance %d",
(int) (CurrentOffset(envPtr) - otherFixup.codeOffset));
}
/*
* Pull the result to top of stack, discard options dict.
*/
OP4( REVERSE, 2);
OP( POP);
/* OK destination */
if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %d",
(int) (CurrentOffset(envPtr) - okFixup.codeOffset));
}
if (count > 1) {
OP1(STR_CONCAT1, count);
count = 1;
}
/* CONTINUE jump to here */
if (TclFixupForwardJumpToHere(envPtr, &endFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad end jump distance %d",
(int) (CurrentOffset(envPtr) - endFixup.codeOffset));
}
bline = envPtr->line;
}
while (count > 255) {
OP1( STR_CONCAT1, 255);
count -= 254;
}
if (count > 1) {
OP1( STR_CONCAT1, count);
}
Tcl_FreeParse(&parse);
if (state != NULL) {
Tcl_RestoreInterpState(interp, state);
TclCompileSyntaxError(interp, envPtr);
TclAdjustStackDepth(-1, envPtr);
}
/* Final target of the multi-jump from all BREAKs */
if (breakOffset > 0) {
TclUpdateInstInt4AtPc(INST_JUMP4, CurrentOffset(envPtr) - breakOffset,
envPtr->codeStart + breakOffset);
}
}
/*
*----------------------------------------------------------------------
*
* TclCompileSwitchCmd --
*
* Procedure called to compile the "switch" command.
*
* Results:
* Returns TCL_OK for successful compile, or TCL_ERROR to defer
* evaluation to runtime (either when it is too complex to get the
* semantics right, or when we know for sure that it is an error but need
* the error to happen at the right time).
*
* Side effects:
* Instructions are added to envPtr to execute the "switch" command at
* runtime.
*
*----------------------------------------------------------------------
*/
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. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr; /* Pointer to tokens in command. */
int numWords; /* Number of words in command. */
Tcl_Token *valueTokenPtr; /* Token for the value to switch on. */
enum {Switch_Exact, Switch_Glob, Switch_Regexp} mode;
/* What kind of switch are we doing? */
Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */
Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */
int *bodyLines; /* Array of line numbers for body list
* items. */
int **bodyContLines; /* Array of continuation line info. */
int noCase; /* Has the -nocase flag been given? */
int foundMode = 0; /* Have we seen a mode flag yet? */
int i, valueIndex;
int result = TCL_ERROR;
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--) {
unsigned size = tokenPtr[1].size;
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 = ckalloc(sizeof(Tcl_Token) * maxLen);
bodyToken = ckalloc(sizeof(Tcl_Token *) * maxLen);
bodyLines = ckalloc(sizeof(int) * maxLen);
bodyContLines = 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;
bodyContLines[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 *) bodyContLines);
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 = ckalloc(sizeof(Tcl_Token *) * numWords);
bodyLines = ckalloc(sizeof(int) * numWords);
bodyContLines = 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) {
goto freeTemporaries;
}
bodyToken[i] = tokenPtr+1;
/*
* TIP #280: Copy line information from regular cmd info.
*/
bodyLines[i] = mapPtr->loc[eclIndex].line[valueIndex+1+i];
bodyContLines[i] = mapPtr->loc[eclIndex].next[valueIndex+1+i];
tokenPtr = TokenAfter(tokenPtr);
}
}
/*
* Fall back to interpreted if the last body is a continuation (it's
* illegal, but this makes the error happen at the right time).
*/
if (bodyToken[numWords-1]->size == 1 &&
bodyToken[numWords-1]->start[0] == '-') {
goto freeTemporaries;
}
/*
* Now we commit to generating code; the parsing stage per se is done.
* Check if we can generate a jump table, since if so that's faster than
* doing an explicit compare with each body. Note that we're definitely
* over-conservative with determining whether we can do the jump table,
* but it handles the most common case well enough.
*/
/* Both methods push the value to match against onto the stack. */
CompileWord(envPtr, valueTokenPtr, interp, valueIndex);
if (mode == Switch_Exact) {
IssueSwitchJumpTable(interp, envPtr, valueIndex, numWords, bodyToken,
bodyLines, bodyContLines);
} else {
IssueSwitchChainedTests(interp, envPtr, mode, noCase, valueIndex,
numWords, bodyToken, bodyLines, bodyContLines);
}
result = TCL_OK;
/*
* Clean up all our temporary space and return.
*/
freeTemporaries:
ckfree(bodyToken);
ckfree(bodyLines);
ckfree(bodyContLines);
if (bodyTokenArray != NULL) {
ckfree(bodyTokenArray);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* IssueSwitchChainedTests --
*
* Generate instructions for a [switch] command that is to be compiled
* into a sequence of tests. This is the generic handle-everything mode
* that inherently has performance that is (on average) linear in the
* number of tests. It is the only mode that can handle -glob and -regexp
* matches, or anything that is case-insensitive. It does not handle the
* wild-and-wooly end of regexp matching (i.e., capture of match results)
* so that's when we spill to the interpreted version.
*
*----------------------------------------------------------------------
*/
static void
IssueSwitchChainedTests(
Tcl_Interp *interp, /* Context for compiling script bodies. */
CompileEnv *envPtr, /* Holds resulting instructions. */
int mode, /* Exact, Glob or Regexp */
int noCase, /* Case-insensitivity flag. */
int valueIndex, /* The value to match against. */
int numBodyTokens, /* Number of tokens describing things the
* switch can match against and bodies to
* execute when the match succeeds. */
Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */
int *bodyLines, /* Array of line numbers for body list
* items. */
int **bodyContLines) /* Array of continuation line info. */
{
enum {Switch_Exact, Switch_Glob, Switch_Regexp};
int foundDefault; /* Flag to indicate whether a "default" clause
* is present. */
JumpFixup *fixupArray; /* Array of forward-jump fixup records. */
unsigned int *fixupTargetArray; /* Array of places for fixups to point at. */
int fixupCount; /* Number of places to fix up. */
int contFixIndex; /* Where the first of the jumps due to a group
* of continuation bodies starts, or -1 if
* there aren't any. */
int contFixCount; /* Number of continuation bodies pointing to
* the current (or next) real body. */
int nextArmFixupIndex;
int simple, exact; /* For extracting the type of regexp. */
int i;
/*
* Generate a test for each arm.
*/
contFixIndex = -1;
contFixCount = 0;
fixupArray = TclStackAlloc(interp, sizeof(JumpFixup) * numBodyTokens);
fixupTargetArray = TclStackAlloc(interp, sizeof(int) * numBodyTokens);
memset(fixupTargetArray, 0, numBodyTokens * sizeof(int));
fixupCount = 0;
foundDefault = 0;
for (i=0 ; i<numBodyTokens ; i+=2) {
nextArmFixupIndex = -1;
if (i!=numBodyTokens-2 || bodyToken[numBodyTokens-2]->size != 7 ||
memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) {
/*
* Generate the test for the arm.
*/
switch (mode) {
case Switch_Exact:
OP( DUP);
TclCompileTokens(interp, bodyToken[i], 1, envPtr);
OP( STR_EQ);
break;
case Switch_Glob:
TclCompileTokens(interp, bodyToken[i], 1, envPtr);
OP4( OVER, 1);
OP1( STR_MATCH, noCase);
break;
case Switch_Regexp:
simple = exact = 0;
/*
* Keep in sync with TclCompileRegexpCmd.
*/
if (bodyToken[i]->type == TCL_TOKEN_TEXT) {
Tcl_DString ds;
if (bodyToken[i]->size == 0) {
/*
* The semantics of regexps are that they always match
* when the RE == "".
*/
PUSH("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, NULL) == TCL_OK){
simple = 1;
PushLiteral(envPtr, Tcl_DStringValue(&ds),
Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
}
}
if (!simple) {
TclCompileTokens(interp, bodyToken[i], 1, envPtr);
}
OP4( OVER, 1);
if (!simple) {
/*
* Pass correct RE compile flags. We use only Int1
* (8-bit), but that handles all the flags we want to
* pass. Don't use TCL_REG_NOSUB as we may have backrefs
* or capture vars.
*/
int cflags = TCL_REG_ADVANCED
| (noCase ? TCL_REG_NOCASE : 0);
OP1(REGEXP, cflags);
} else if (exact && !noCase) {
OP( STR_EQ);
} else {
OP1(STR_MATCH, noCase);
}
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 BODY()
* because we may have synthesized the tokens in a non-standard
* pattern.
*/
OP( POP);
envPtr->line = bodyLines[i+1]; /* TIP #280 */
envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */
TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
if (!foundDefault) {
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
&fixupArray[fixupCount]);
fixupCount++;
fixupTargetArray[nextArmFixupIndex] = CurrentOffset(envPtr);
}
}
/*
* Discard the value we are matching against unless we've had a default
* clause (in which case it will already be gone due to the code at the
* start of processing an arm, guaranteed) and make the result of the
* command an empty string.
*/
if (!foundDefault) {
OP( POP);
PUSH("");
}
/*
* Do jump fixups for arms that were executed. First, fill in the jumps of
* all jumps that don't point elsewhere to point to here.
*/
for (i=0 ; i<fixupCount ; i++) {
if (fixupTargetArray[i] == 0) {
fixupTargetArray[i] = envPtr->codeNext-envPtr->codeStart;
}
}
/*
* Now scan backwards over all the jumps (all of which are forward jumps)
* doing each one. When we do one and there is a size changes, we must
* scan back over all the previous ones and see if they need adjusting
* before proceeding with further jump fixups (the interleaved nature of
* all the jumps makes this impossible to do without nested loops).
*/
for (i=fixupCount-1 ; i>=0 ; i--) {
if (TclFixupForwardJump(envPtr, &fixupArray[i],
fixupTargetArray[i] - fixupArray[i].codeOffset, 127)) {
int j;
for (j=i-1 ; j>=0 ; j--) {
if (fixupTargetArray[j] > fixupArray[i].codeOffset) {
fixupTargetArray[j] += 3;
}
}
}
}
TclStackFree(interp, fixupTargetArray);
TclStackFree(interp, fixupArray);
}
/*
*----------------------------------------------------------------------
*
* IssueSwitchJumpTable --
*
* Generate instructions for a [switch] command that is to be compiled
* into a jump table. This only handles the case where case-sensitive,
* exact matching is used, but this is actually the most common case in
* real code.
*
*----------------------------------------------------------------------
*/
static void
IssueSwitchJumpTable(
Tcl_Interp *interp, /* Context for compiling script bodies. */
CompileEnv *envPtr, /* Holds resulting instructions. */
int valueIndex, /* The value to match against. */
int numBodyTokens, /* Number of tokens describing things the
* switch can match against and bodies to
* execute when the match succeeds. */
Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */
int *bodyLines, /* Array of line numbers for body list
* items. */
int **bodyContLines) /* Array of continuation line info. */
{
JumptableInfo *jtPtr;
int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation;
int mustGenerate, foundDefault, jumpToDefault, i;
Tcl_DString buffer;
Tcl_HashEntry *hPtr;
/*
* 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 = ckalloc(sizeof(JumptableInfo));
Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);
infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr);
finalFixups = TclStackAlloc(interp, sizeof(int) * (numBodyTokens/2));
foundDefault = 0;
mustGenerate = 1;
/*
* Next, issue the instruction to do the jump, together with what we want
* to do if things do not work out (jump to either the default clause or
* the "default" default, which just sets the result to empty). Note that
* we will come back and rewrite the jump's offset parameter when we know
* what it should be, and that all jumps we issue are of the wide kind
* because that makes the code much easier to debug!
*/
jumpLocation = CurrentOffset(envPtr);
OP4( JUMP_TABLE, infoIndex);
jumpToDefault = CurrentOffset(envPtr);
OP4( JUMP4, 0);
for (i=0 ; i<numBodyTokens ; i+=2) {
/*
* For each arm, we must first work out what to do with the match
* term.
*/
if (i!=numBodyTokens-2 || bodyToken[numBodyTokens-2]->size != 7 ||
memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) {
/*
* This is not a default clause, so insert the current location as
* a target in the jump table (assuming it isn't already there,
* which would indicate that this clause is probably masked by an
* earlier one). Note that we use a Tcl_DString here simply
* because the hash API does not let us specify the string length.
*/
Tcl_DStringInit(&buffer);
TclDStringAppendToken(&buffer, bodyToken[i]);
hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable,
Tcl_DStringValue(&buffer), &isNew);
if (isNew) {
/*
* First time we've encountered this match clause, so it must
* point to here.
*/
Tcl_SetHashValue(hPtr, CurrentOffset(envPtr) - jumpLocation);
}
Tcl_DStringFree(&buffer);
} else {
/*
* This is a default clause, so patch up the fallthrough from the
* INST_JUMP_TABLE instruction to here.
*/
foundDefault = 1;
isNew = 1;
TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault,
envPtr->codeStart+jumpToDefault+1);
}
/*
* Now, for each arm we must deal with the body of the clause.
*
* If this is a continuation body (never true of a final clause,
* whether default or not) we're done because the next jump target
* will also point here, so we advance to the next clause.
*/
if (bodyToken[i+1]->size == 1 && bodyToken[i+1]->start[0] == '-') {
mustGenerate = 1;
continue;
}
/*
* Also skip this arm if its only match clause is masked. (We could
* probably be more aggressive about this, but that would be much more
* difficult to get right.)
*/
if (!isNew && !mustGenerate) {
continue;
}
mustGenerate = 0;
/*
* Compile the body of the arm.
*/
envPtr->line = bodyLines[i+1]; /* TIP #280 */
envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */
TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
/*
* Compile a jump in to the end of the command if this body is
* anything other than a user-supplied default arm (to either skip
* over the remaining bodies or the code that generates an empty
* result).
*/
if (i+2 < numBodyTokens || !foundDefault) {
finalFixups[numRealBodies++] = CurrentOffset(envPtr);
/*
* Easier by far to issue this jump as a fixed-width jump, since
* otherwise we'd need to do a lot more (and more awkward)
* rewriting when we fixed this all up.
*/
OP4( JUMP4, 0);
TclAdjustStackDepth(-1, 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);
PUSH("");
}
/*
* 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.
*/
TclStackFree(interp, finalFixups);
}
/*
*----------------------------------------------------------------------
*
* DupJumptableInfo, FreeJumptableInfo --
*
* Functions to duplicate, release and print a jump-table created for use
* with the INST_JUMP_TABLE instruction.
*
* Results:
* DupJumptableInfo: a copy of the jump-table
* FreeJumptableInfo: none
* PrintJumptableInfo: none
* DisassembleJumptableInfo: none
*
* Side effects:
* DupJumptableInfo: allocates memory
* FreeJumptableInfo: releases memory
* PrintJumptableInfo: none
* DisassembleJumptableInfo: none
*
*----------------------------------------------------------------------
*/
static ClientData
DupJumptableInfo(
ClientData clientData)
{
JumptableInfo *jtPtr = clientData;
JumptableInfo *newJtPtr = 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(jtPtr);
}
static void
PrintJumptableInfo(
ClientData clientData,
Tcl_Obj *appendObj,
ByteCode *codePtr,
unsigned int pcOffset)
{
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);
}
}
static void
DisassembleJumptableInfo(
ClientData clientData,
Tcl_Obj *dictObj,
ByteCode *codePtr,
unsigned int pcOffset)
{
JumptableInfo *jtPtr = clientData;
Tcl_Obj *mapping = Tcl_NewObj();
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
const char *keyPtr;
int offset;
hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) {
keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
offset = PTR2INT(Tcl_GetHashValue(hPtr));
Tcl_DictObjPut(NULL, mapping, Tcl_NewStringObj(keyPtr, -1),
Tcl_NewIntObj(offset));
}
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("mapping", -1), mapping);
}
/*
*----------------------------------------------------------------------
*
* TclCompileTailcallCmd --
*
* Procedure called to compile the "tailcall" 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 "tailcall" command at
* runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileTailcallCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int i;
if (parsePtr->numWords < 2 || parsePtr->numWords > 256
|| envPtr->procPtr == NULL) {
return TCL_ERROR;
}
/* make room for the nsObjPtr */
/* TODO: Doesn't this have to be a known value? */
CompileWord(envPtr, tokenPtr, interp, 0);
for (i=1 ; i<parsePtr->numWords ; i++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, i);
}
TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords, envPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileThrowCmd --
*
* Procedure called to compile the "throw" 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 "throw" command at
* runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileThrowCmd(
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 */
int numWords = parsePtr->numWords;
Tcl_Token *codeToken, *msgToken;
Tcl_Obj *objPtr;
int codeKnown, codeIsList, codeIsValid, len;
if (numWords != 3) {
return TCL_ERROR;
}
codeToken = TokenAfter(parsePtr->tokenPtr);
msgToken = TokenAfter(codeToken);
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
codeKnown = TclWordKnownAtCompileTime(codeToken, objPtr);
/*
* First we must emit the code to substitute the arguments. This
* must come first in case substitution raises errors.
*/
if (!codeKnown) {
CompileWord(envPtr, codeToken, interp, 1);
PUSH( "-errorcode");
}
CompileWord(envPtr, msgToken, interp, 2);
codeIsList = codeKnown && (TCL_OK ==
Tcl_ListObjLength(interp, objPtr, &len));
codeIsValid = codeIsList && (len != 0);
if (codeIsValid) {
Tcl_Obj *errPtr, *dictPtr;
TclNewLiteralStringObj(errPtr, "-errorcode");
TclNewObj(dictPtr);
Tcl_DictObjPut(NULL, dictPtr, errPtr, objPtr);
TclEmitPush(TclAddLiteralObj(envPtr, dictPtr, NULL), envPtr);
}
TclDecrRefCount(objPtr);
/*
* Simpler bytecodes when we detect invalid arguments at compile time.
*/
if (codeKnown && !codeIsValid) {
OP( POP);
if (codeIsList) {
/* Must be an empty list */
goto issueErrorForEmptyCode;
}
TclCompileSyntaxError(interp, envPtr);
return TCL_OK;
}
if (!codeKnown) {
/*
* Argument validity checking has to be done by bytecode at
* run time.
*/
OP4( REVERSE, 3);
OP( DUP);
OP( LIST_LENGTH);
OP1( JUMP_FALSE1, 16);
OP4( LIST, 2);
OP44( RETURN_IMM, TCL_ERROR, 0);
TclAdjustStackDepth(2, envPtr);
OP( POP);
OP( POP);
OP( POP);
issueErrorForEmptyCode:
PUSH( "type must be non-empty list");
PUSH( "-errorcode {TCL OPERATION THROW BADEXCEPTION}");
}
OP44( RETURN_IMM, TCL_ERROR, 0);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileTryCmd --
*
* Procedure called to compile the "try" command.
*
* Results:
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
* evaluation to runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "try" command at
* runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileTryCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
int numWords = parsePtr->numWords, numHandlers, result = TCL_ERROR;
Tcl_Token *bodyToken, *finallyToken, *tokenPtr;
Tcl_Token **handlerTokens = NULL;
Tcl_Obj **matchClauses = NULL;
int *matchCodes=NULL, *resultVarIndices=NULL, *optionVarIndices=NULL;
int i;
if (numWords < 2) {
return TCL_ERROR;
}
bodyToken = TokenAfter(parsePtr->tokenPtr);
if (numWords == 2) {
/*
* No handlers or finally; do nothing beyond evaluating the body.
*/
DefineLineInformation; /* TIP #280 */
BODY(bodyToken, 1);
return TCL_OK;
}
numWords -= 2;
tokenPtr = TokenAfter(bodyToken);
/*
* Extract information about what handlers there are.
*/
numHandlers = numWords >> 2;
numWords -= numHandlers * 4;
if (numHandlers > 0) {
handlerTokens = TclStackAlloc(interp, sizeof(Tcl_Token*)*numHandlers);
matchClauses = TclStackAlloc(interp, sizeof(Tcl_Obj *) * numHandlers);
memset(matchClauses, 0, sizeof(Tcl_Obj *) * numHandlers);
matchCodes = TclStackAlloc(interp, sizeof(int) * numHandlers);
resultVarIndices = TclStackAlloc(interp, sizeof(int) * numHandlers);
optionVarIndices = TclStackAlloc(interp, sizeof(int) * numHandlers);
for (i=0 ; i<numHandlers ; i++) {
Tcl_Obj *tmpObj, **objv;
int objc;
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
goto failedToCompile;
}
if (tokenPtr[1].size == 4
&& !strncmp(tokenPtr[1].start, "trap", 4)) {
/*
* Parse the list of errorCode words to match against.
*/
matchCodes[i] = TCL_ERROR;
tokenPtr = TokenAfter(tokenPtr);
TclNewObj(tmpObj);
Tcl_IncrRefCount(tmpObj);
if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)
|| Tcl_ListObjLength(NULL, tmpObj, &objc) != TCL_OK
|| (objc == 0)) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
Tcl_ListObjReplace(NULL, tmpObj, 0, 0, 0, NULL);
matchClauses[i] = tmpObj;
} else if (tokenPtr[1].size == 2
&& !strncmp(tokenPtr[1].start, "on", 2)) {
int code;
/*
* Parse the result code to look for.
*/
tokenPtr = TokenAfter(tokenPtr);
TclNewObj(tmpObj);
Tcl_IncrRefCount(tmpObj);
if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
if (TCL_ERROR == TclGetCompletionCodeFromObj(NULL, tmpObj, &code)) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
matchCodes[i] = code;
TclDecrRefCount(tmpObj);
} else {
goto failedToCompile;
}
/*
* Parse the variable binding.
*/
tokenPtr = TokenAfter(tokenPtr);
TclNewObj(tmpObj);
Tcl_IncrRefCount(tmpObj);
if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
if (Tcl_ListObjGetElements(NULL, tmpObj, &objc, &objv) != TCL_OK
|| (objc > 2)) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
if (objc > 0) {
int len;
const char *varname = Tcl_GetStringFromObj(objv[0], &len);
resultVarIndices[i] = LocalScalar(varname, len, envPtr);
if (resultVarIndices[i] < 0) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
} else {
resultVarIndices[i] = -1;
}
if (objc == 2) {
int len;
const char *varname = Tcl_GetStringFromObj(objv[1], &len);
optionVarIndices[i] = LocalScalar(varname, len, envPtr);
if (optionVarIndices[i] < 0) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
} else {
optionVarIndices[i] = -1;
}
TclDecrRefCount(tmpObj);
/*
* Extract the body for this handler.
*/
tokenPtr = TokenAfter(tokenPtr);
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
goto failedToCompile;
}
if (tokenPtr[1].size == 1 && tokenPtr[1].start[0] == '-') {
handlerTokens[i] = NULL;
} else {
handlerTokens[i] = tokenPtr;
}
tokenPtr = TokenAfter(tokenPtr);
}
if (handlerTokens[numHandlers-1] == NULL) {
goto failedToCompile;
}
}
/*
* Parse the finally clause
*/
if (numWords == 0) {
finallyToken = NULL;
} else if (numWords == 2) {
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 7
|| strncmp(tokenPtr[1].start, "finally", 7)) {
goto failedToCompile;
}
finallyToken = TokenAfter(tokenPtr);
} else {
goto failedToCompile;
}
/*
* Issue the bytecode.
*/
if (!finallyToken) {
result = IssueTryClausesInstructions(interp, envPtr, bodyToken,
numHandlers, matchCodes, matchClauses, resultVarIndices,
optionVarIndices, handlerTokens);
} else if (numHandlers == 0) {
result = IssueTryFinallyInstructions(interp, envPtr, bodyToken,
finallyToken);
} else {
result = IssueTryClausesFinallyInstructions(interp, envPtr, bodyToken,
numHandlers, matchCodes, matchClauses, resultVarIndices,
optionVarIndices, handlerTokens, finallyToken);
}
/*
* Delete any temporary state and finish off.
*/
failedToCompile:
if (numHandlers > 0) {
for (i=0 ; i<numHandlers ; i++) {
if (matchClauses[i]) {
TclDecrRefCount(matchClauses[i]);
}
}
TclStackFree(interp, optionVarIndices);
TclStackFree(interp, resultVarIndices);
TclStackFree(interp, matchCodes);
TclStackFree(interp, matchClauses);
TclStackFree(interp, handlerTokens);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* IssueTryClausesInstructions, IssueTryClausesFinallyInstructions,
* IssueTryFinallyInstructions --
*
* The code generators for [try]. Split from the parsing engine for
* reasons of developer sanity, and also split between no-finally,
* just-finally and with-finally cases because so many of the details of
* generation vary between the three.
*
* The macros below make the instruction issuing easier to follow.
*
*----------------------------------------------------------------------
*/
static int
IssueTryClausesInstructions(
Tcl_Interp *interp,
CompileEnv *envPtr,
Tcl_Token *bodyToken,
int numHandlers,
int *matchCodes,
Tcl_Obj **matchClauses,
int *resultVars,
int *optionVars,
Tcl_Token **handlerTokens)
{
DefineLineInformation; /* TIP #280 */
int range, resultVar, optionsVar;
int i, j, len, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0;
int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
int *noError;
char buf[TCL_INTEGER_SPACE];
resultVar = AnonymousLocal(envPtr);
optionsVar = AnonymousLocal(envPtr);
if (resultVar < 0 || optionsVar < 0) {
return TCL_ERROR;
}
/*
* Check if we're supposed to trap a normal TCL_OK completion of the body.
* If not, we can handle that case much more efficiently.
*/
for (i=0 ; i<numHandlers ; i++) {
if (matchCodes[i] == 0) {
trapZero = 1;
break;
}
}
/*
* Compile the body, trapping any error in it so that we can trap on it
* and/or run a finally clause. Note that there must be at least one
* on/trap clause; when none is present, this whole function is not called
* (and it's never called when there's a finally clause).
*/
range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
OP4( BEGIN_CATCH4, range);
ExceptionRangeStarts(envPtr, range);
BODY( bodyToken, 1);
ExceptionRangeEnds(envPtr, range);
if (!trapZero) {
OP( END_CATCH);
JUMP4( JUMP, afterBody);
TclAdjustStackDepth(-1, envPtr);
} else {
PUSH( "0");
OP4( REVERSE, 2);
OP1( JUMP1, 4);
TclAdjustStackDepth(-2, envPtr);
}
ExceptionRangeTarget(envPtr, range, catchOffset);
OP( PUSH_RETURN_CODE);
OP( PUSH_RESULT);
OP( PUSH_RETURN_OPTIONS);
OP( END_CATCH);
STORE( optionsVar);
OP( POP);
STORE( resultVar);
OP( POP);
/*
* Now we handle all the registered 'on' and 'trap' handlers in order.
* For us to be here, there must be at least one handler.
*
* Slight overallocation, but reduces size of this function.
*/
addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
noError = TclStackAlloc(interp, sizeof(int)*numHandlers);
for (i=0 ; i<numHandlers ; i++) {
noError[i] = -1;
sprintf(buf, "%d", matchCodes[i]);
OP( DUP);
PushLiteral(envPtr, buf, strlen(buf));
OP( EQ);
JUMP4( JUMP_FALSE, notCodeJumpSource);
if (matchClauses[i]) {
const char *p;
Tcl_ListObjLength(NULL, matchClauses[i], &len);
/*
* Match the errorcode according to try/trap rules.
*/
LOAD( optionsVar);
PUSH( "-errorcode");
OP4( DICT_GET, 1);
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
p = Tcl_GetStringFromObj(matchClauses[i], &len);
PushLiteral(envPtr, p, len);
OP( STR_EQ);
JUMP4( JUMP_FALSE, notECJumpSource);
} else {
notECJumpSource = -1; /* LINT */
}
OP( POP);
/*
* There is no finally clause, so we can avoid wrapping a catch
* context around the handler. That simplifies what instructions need
* to be issued a lot since we can let errors just fall through.
*/
if (resultVars[i] >= 0) {
LOAD( resultVar);
STORE( resultVars[i]);
OP( POP);
if (optionVars[i] >= 0) {
LOAD( optionsVar);
STORE( optionVars[i]);
OP( POP);
}
}
if (!handlerTokens[i]) {
forwardsNeedFixing = 1;
JUMP4( JUMP, forwardsToFix[i]);
TclAdjustStackDepth(1, envPtr);
} else {
int dontChangeOptions;
forwardsToFix[i] = -1;
if (forwardsNeedFixing) {
forwardsNeedFixing = 0;
for (j=0 ; j<i ; j++) {
if (forwardsToFix[j] == -1) {
continue;
}
FIXJUMP4(forwardsToFix[j]);
forwardsToFix[j] = -1;
}
}
range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
OP4( BEGIN_CATCH4, range);
ExceptionRangeStarts(envPtr, range);
BODY( handlerTokens[i], 5+i*4);
ExceptionRangeEnds(envPtr, range);
OP( END_CATCH);
JUMP4( JUMP, noError[i]);
ExceptionRangeTarget(envPtr, range, catchOffset);
TclAdjustStackDepth(-1, envPtr);
OP( PUSH_RESULT);
OP( PUSH_RETURN_OPTIONS);
OP( PUSH_RETURN_CODE);
OP( END_CATCH);
PUSH( "1");
OP( EQ);
JUMP1( JUMP_FALSE, dontChangeOptions);
LOAD( optionsVar);
OP4( REVERSE, 2);
STORE( optionsVar);
OP( POP);
PUSH( "-during");
OP4( REVERSE, 2);
OP44( DICT_SET, 1, optionsVar);
TclAdjustStackDepth(-1, envPtr);
FIXJUMP1( dontChangeOptions);
OP4( REVERSE, 2);
INVOKE( RETURN_STK);
}
JUMP4( JUMP, addrsToFix[i]);
if (matchClauses[i]) {
FIXJUMP4( notECJumpSource);
}
FIXJUMP4( notCodeJumpSource);
}
/*
* Drop the result code since it didn't match any clause, and reissue the
* exception. Note also that INST_RETURN_STK can proceed to the next
* instruction.
*/
OP( POP);
LOAD( optionsVar);
LOAD( resultVar);
INVOKE( RETURN_STK);
/*
* Fix all the jumps from taken clauses to here (which is the end of the
* [try]).
*/
if (!trapZero) {
FIXJUMP4(afterBody);
}
for (i=0 ; i<numHandlers ; i++) {
FIXJUMP4(addrsToFix[i]);
if (noError[i] != -1) {
FIXJUMP4(noError[i]);
}
}
TclStackFree(interp, noError);
TclStackFree(interp, forwardsToFix);
TclStackFree(interp, addrsToFix);
return TCL_OK;
}
static int
IssueTryClausesFinallyInstructions(
Tcl_Interp *interp,
CompileEnv *envPtr,
Tcl_Token *bodyToken,
int numHandlers,
int *matchCodes,
Tcl_Obj **matchClauses,
int *resultVars,
int *optionVars,
Tcl_Token **handlerTokens,
Tcl_Token *finallyToken) /* Not NULL */
{
DefineLineInformation; /* TIP #280 */
int range, resultVar, optionsVar, i, j, len, forwardsNeedFixing = 0;
int trapZero = 0, afterBody = 0, finalOK, finalError, noFinalError;
int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
char buf[TCL_INTEGER_SPACE];
resultVar = AnonymousLocal(envPtr);
optionsVar = AnonymousLocal(envPtr);
if (resultVar < 0 || optionsVar < 0) {
return TCL_ERROR;
}
/*
* Check if we're supposed to trap a normal TCL_OK completion of the body.
* If not, we can handle that case much more efficiently.
*/
for (i=0 ; i<numHandlers ; i++) {
if (matchCodes[i] == 0) {
trapZero = 1;
break;
}
}
/*
* Compile the body, trapping any error in it so that we can trap on it
* (if any trap matches) and run a finally clause.
*/
range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
OP4( BEGIN_CATCH4, range);
ExceptionRangeStarts(envPtr, range);
BODY( bodyToken, 1);
ExceptionRangeEnds(envPtr, range);
if (!trapZero) {
OP( END_CATCH);
STORE( resultVar);
OP( POP);
PUSH( "-level 0 -code 0");
STORE( optionsVar);
OP( POP);
JUMP4( JUMP, afterBody);
} else {
PUSH( "0");
OP4( REVERSE, 2);
OP1( JUMP1, 4);
TclAdjustStackDepth(-2, envPtr);
}
ExceptionRangeTarget(envPtr, range, catchOffset);
OP( PUSH_RETURN_CODE);
OP( PUSH_RESULT);
OP( PUSH_RETURN_OPTIONS);
OP( END_CATCH);
STORE( optionsVar);
OP( POP);
STORE( resultVar);
OP( POP);
/*
* Now we handle all the registered 'on' and 'trap' handlers in order.
*
* Slight overallocation, but reduces size of this function.
*/
addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
for (i=0 ; i<numHandlers ; i++) {
int noTrapError, trapError;
const char *p;
sprintf(buf, "%d", matchCodes[i]);
OP( DUP);
PushLiteral(envPtr, buf, strlen(buf));
OP( EQ);
JUMP4( JUMP_FALSE, notCodeJumpSource);
if (matchClauses[i]) {
Tcl_ListObjLength(NULL, matchClauses[i], &len);
/*
* Match the errorcode according to try/trap rules.
*/
LOAD( optionsVar);
PUSH( "-errorcode");
OP4( DICT_GET, 1);
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
p = Tcl_GetStringFromObj(matchClauses[i], &len);
PushLiteral(envPtr, p, len);
OP( STR_EQ);
JUMP4( JUMP_FALSE, notECJumpSource);
} else {
notECJumpSource = -1; /* LINT */
}
OP( POP);
/*
* There is a finally clause, so we need a fairly complex sequence of
* instructions to deal with an on/trap handler because we must call
* the finally handler *and* we need to substitute the result from a
* failed trap for the result from the main script.
*/
if (resultVars[i] >= 0 || handlerTokens[i]) {
range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
OP4( BEGIN_CATCH4, range);
ExceptionRangeStarts(envPtr, range);
}
if (resultVars[i] >= 0) {
LOAD( resultVar);
STORE( resultVars[i]);
OP( POP);
if (optionVars[i] >= 0) {
LOAD( optionsVar);
STORE( optionVars[i]);
OP( POP);
}
if (!handlerTokens[i]) {
/*
* No handler. Will not be the last handler (that is a
* condition that is checked by the caller). Chain to the next
* one.
*/
ExceptionRangeEnds(envPtr, range);
OP( END_CATCH);
forwardsNeedFixing = 1;
JUMP4( JUMP, forwardsToFix[i]);
goto finishTrapCatchHandling;
}
} else if (!handlerTokens[i]) {
/*
* No handler. Will not be the last handler (that condition is
* checked by the caller). Chain to the next one.
*/
forwardsNeedFixing = 1;
JUMP4( JUMP, forwardsToFix[i]);
goto endOfThisArm;
}
/*
* Got a handler. Make sure that any pending patch-up actions from
* previous unprocessed handlers are dealt with now that we know where
* they are to jump to.
*/
if (forwardsNeedFixing) {
forwardsNeedFixing = 0;
OP1( JUMP1, 7);
for (j=0 ; j<i ; j++) {
if (forwardsToFix[j] == -1) {
continue;
}
FIXJUMP4( forwardsToFix[j]);
forwardsToFix[j] = -1;
}
OP4( BEGIN_CATCH4, range);
}
BODY( handlerTokens[i], 5+i*4);
ExceptionRangeEnds(envPtr, range);
PUSH( "0");
OP( PUSH_RETURN_OPTIONS);
OP4( REVERSE, 3);
OP1( JUMP1, 5);
TclAdjustStackDepth(-3, envPtr);
forwardsToFix[i] = -1;
/*
* Error in handler or setting of variables; replace the stored
* exception with the new one. Note that we only push this if we have
* either a body or some variable setting here. Otherwise this code is
* unreachable.
*/
finishTrapCatchHandling:
ExceptionRangeTarget(envPtr, range, catchOffset);
OP( PUSH_RETURN_OPTIONS);
OP( PUSH_RETURN_CODE);
OP( PUSH_RESULT);
OP( END_CATCH);
STORE( resultVar);
OP( POP);
PUSH( "1");
OP( EQ);
JUMP1( JUMP_FALSE, noTrapError);
LOAD( optionsVar);
PUSH( "-during");
OP4( REVERSE, 3);
STORE( optionsVar);
OP( POP);
OP44( DICT_SET, 1, optionsVar);
TclAdjustStackDepth(-1, envPtr);
JUMP1( JUMP, trapError);
FIXJUMP1( noTrapError);
STORE( optionsVar);
FIXJUMP1( trapError);
/* Skip POP at end; can clean up with subsequent POP */
if (i+1 < numHandlers) {
OP( POP);
}
endOfThisArm:
if (i+1 < numHandlers) {
JUMP4( JUMP, addrsToFix[i]);
TclAdjustStackDepth(1, envPtr);
}
if (matchClauses[i]) {
FIXJUMP4( notECJumpSource);
}
FIXJUMP4( notCodeJumpSource);
}
/*
* Drop the result code, and fix all the jumps from taken clauses - which
* drop the result code as their first action - to point straight after
* (i.e., to the start of the finally clause).
*/
OP( POP);
for (i=0 ; i<numHandlers-1 ; i++) {
FIXJUMP4( addrsToFix[i]);
}
TclStackFree(interp, forwardsToFix);
TclStackFree(interp, addrsToFix);
/*
* Process the finally clause (at last!) Note that we do not wrap this in
* error handlers because we would just rethrow immediately anyway. Then
* (on normal success) we reissue the exception. Note also that
* INST_RETURN_STK can proceed to the next instruction; that'll be the
* next command (or some inter-command manipulation).
*/
if (!trapZero) {
FIXJUMP4( afterBody);
}
range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
OP4( BEGIN_CATCH4, range);
ExceptionRangeStarts(envPtr, range);
BODY( finallyToken, 3 + 4*numHandlers);
ExceptionRangeEnds(envPtr, range);
OP( END_CATCH);
OP( POP);
JUMP1( JUMP, finalOK);
ExceptionRangeTarget(envPtr, range, catchOffset);
OP( PUSH_RESULT);
OP( PUSH_RETURN_OPTIONS);
OP( PUSH_RETURN_CODE);
OP( END_CATCH);
PUSH( "1");
OP( EQ);
JUMP1( JUMP_FALSE, noFinalError);
LOAD( optionsVar);
PUSH( "-during");
OP4( REVERSE, 3);
STORE( optionsVar);
OP( POP);
OP44( DICT_SET, 1, optionsVar);
TclAdjustStackDepth(-1, envPtr);
OP( POP);
JUMP1( JUMP, finalError);
TclAdjustStackDepth(1, envPtr);
FIXJUMP1( noFinalError);
STORE( optionsVar);
OP( POP);
FIXJUMP1( finalError);
STORE( resultVar);
OP( POP);
FIXJUMP1( finalOK);
LOAD( optionsVar);
LOAD( resultVar);
INVOKE( RETURN_STK);
return TCL_OK;
}
static int
IssueTryFinallyInstructions(
Tcl_Interp *interp,
CompileEnv *envPtr,
Tcl_Token *bodyToken,
Tcl_Token *finallyToken)
{
DefineLineInformation; /* TIP #280 */
int range, jumpOK, jumpSplice;
/*
* Note that this one is simple enough that we can issue it without
* needing a local variable table, making it a universal compilation.
*/
range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
OP4( BEGIN_CATCH4, range);
ExceptionRangeStarts(envPtr, range);
BODY( bodyToken, 1);
ExceptionRangeEnds(envPtr, range);
OP1( JUMP1, 3);
TclAdjustStackDepth(-1, envPtr);
ExceptionRangeTarget(envPtr, range, catchOffset);
OP( PUSH_RESULT);
OP( PUSH_RETURN_OPTIONS);
OP( END_CATCH);
range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
OP4( BEGIN_CATCH4, range);
ExceptionRangeStarts(envPtr, range);
BODY( finallyToken, 3);
ExceptionRangeEnds(envPtr, range);
OP( END_CATCH);
OP( POP);
JUMP1( JUMP, jumpOK);
ExceptionRangeTarget(envPtr, range, catchOffset);
OP( PUSH_RESULT);
OP( PUSH_RETURN_OPTIONS);
OP( PUSH_RETURN_CODE);
OP( END_CATCH);
PUSH( "1");
OP( EQ);
JUMP1( JUMP_FALSE, jumpSplice);
PUSH( "-during");
OP4( OVER, 3);
OP4( LIST, 2);
OP( LIST_CONCAT);
FIXJUMP1( jumpSplice);
OP4( REVERSE, 4);
OP( POP);
OP( POP);
OP1( JUMP1, 7);
FIXJUMP1( jumpOK);
OP4( REVERSE, 2);
INVOKE( RETURN_STK);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileUnsetCmd --
*
* Procedure called to compile the "unset" command.
*
* Results:
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
* evaluation to runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "unset" command at
* runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileUnsetCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr;
int isScalar, localIndex, flags = 1, i, varCount = 0, haveFlags = 0;
/* TODO: Consider support for compiling expanded args. */
/*
* Verify that all words - except the first non-option one - are known at
* compile time so that we can handle them without needing to do a nasty
* push/rotate. [Bug 3970f54c4e]
*/
for (i=1,varTokenPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) {
Tcl_Obj *leadingWord = Tcl_NewObj();
varTokenPtr = TokenAfter(varTokenPtr);
if (!TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) {
TclDecrRefCount(leadingWord);
/*
* We can tolerate non-trivial substitutions in the first variable
* to be unset. If a '--' or '-nocomplain' was present, anything
* goes in that one place! (All subsequent variable names must be
* constants since we don't want to have to push them all first.)
*/
if (varCount == 0) {
if (haveFlags) {
continue;
}
/*
* In fact, we're OK as long as we're the first argument *and*
* we provably don't start with a '-'. If that is true, then
* even if everything else is varying, we still can't be a
* flag. Otherwise we'll spill to runtime to place a limit on
* the trickiness.
*/
if (varTokenPtr->type == TCL_TOKEN_WORD
&& varTokenPtr[1].type == TCL_TOKEN_TEXT
&& varTokenPtr[1].size > 0
&& varTokenPtr[1].start[0] != '-') {
continue;
}
}
return TCL_ERROR;
}
if (varCount == 0) {
const char *bytes;
int len;
bytes = Tcl_GetStringFromObj(leadingWord, &len);
if (i == 1 && len == 11 && !strncmp("-nocomplain", bytes, 11)) {
flags = 0;
haveFlags++;
} else if (i == (2 - flags) && len == 2 && !strncmp("--", bytes, 2)) {
haveFlags++;
} else {
varCount++;
}
} else {
varCount++;
}
TclDecrRefCount(leadingWord);
}
/*
* Issue instructions to unset each of the named variables.
*/
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
for (i=0; i<haveFlags;i++) {
varTokenPtr = TokenAfter(varTokenPtr);
}
for (i=1+haveFlags ; i<parsePtr->numWords ; i++) {
/*
* Decide if we can use a frame slot for the var/array name or if we
* need to emit code to compute and push the name at runtime. We use a
* frame slot (entry in the array of local vars) if we are compiling a
* procedure body and if the name is simple text that does not include
* namespace qualifiers.
*/
PushVarNameWord(interp, varTokenPtr, envPtr, 0,
&localIndex, &isScalar, i);
/*
* Emit instructions to unset the variable.
*/
if (isScalar) {
if (localIndex < 0) {
OP1( UNSET_STK, flags);
} else {
OP14( UNSET_SCALAR, flags, localIndex);
}
} else {
if (localIndex < 0) {
OP1( UNSET_ARRAY_STK, flags);
} else {
OP14( UNSET_ARRAY, flags, localIndex);
}
}
varTokenPtr = TokenAfter(varTokenPtr);
}
PUSH("");
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* 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. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *testTokenPtr, *bodyTokenPtr;
JumpFixup jumpEvalCondFixup;
int testCodeOffset, bodyCodeOffset, jumpDist, range, code, boolVal;
int loopMayEnd = 1; /* This is set to 0 if it is recognized as an
* infinite loop. */
Tcl_Obj *boolObj;
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 = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
/*
* 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 &= ~1;
testCodeOffset = CurrentOffset(envPtr);
}
/*
* Compile the loop body.
*/
bodyCodeOffset = ExceptionRangeStarts(envPtr, range);
if (!loopMayEnd) {
envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset;
}
BODY(bodyTokenPtr, 2);
ExceptionRangeEnds(envPtr, range);
OP( POP);
/*
* 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;
}
SetLineInformation(1);
TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
if (jumpDist > 127) {
TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
} else {
TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
}
} 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);
TclFinalizeLoopExceptionRange(envPtr, range);
/*
* The while command's result is an empty string.
*/
pushResult:
PUSH("");
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileYieldCmd --
*
* Procedure called to compile the "yield" 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 "yield" command at
* runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileYieldCmd(
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 || parsePtr->numWords > 2) {
return TCL_ERROR;
}
if (parsePtr->numWords == 1) {
PUSH("");
} else {
DefineLineInformation; /* TIP #280 */
Tcl_Token *valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, valueTokenPtr, interp, 1);
}
OP( YIELD);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileYieldToCmd --
*
* Procedure called to compile the "yieldto" 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 "yieldto" command at
* runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileYieldToCmd(
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 = TokenAfter(parsePtr->tokenPtr);
int i;
if (parsePtr->numWords < 2) {
return TCL_ERROR;
}
OP( NS_CURRENT);
for (i = 1 ; i < parsePtr->numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
OP4( LIST, i);
OP( YIELD_TO_INVOKE);
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)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
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)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int words;
/* TODO: Consider support for compiling expanded args. */
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.
*/
OP4( REVERSE, words-1);
}
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)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 3) {
PUSH("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 = AnonymousLocal(envPtr);
int words;
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
STORE(tmpIndex);
TclEmitOpcode(instruction, envPtr);
for (words=3 ; words<parsePtr->numWords ;) {
LOAD(tmpIndex);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, words);
if (++words < parsePtr->numWords) {
STORE(tmpIndex);
}
TclEmitOpcode(instruction, envPtr);
}
for (; words>3 ; words--) {
OP( BITAND);
}
/*
* Drop the value from the temp variable; retaining that reference
* might be expensive elsewhere.
*/
OP14( UNSET_SCALAR, 0, tmpIndex);
}
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)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int words;
/*
* This one has its own implementation because the ** operator is the only
* one with right associativity.
*/
for (words=1 ; words<parsePtr->numWords ; words++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, words);
}
if (parsePtr->numWords <= 2) {
PUSH("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)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int words;
/* TODO: Consider support for compiling expanded args. */
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)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int words;
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords == 1) {
/*
* Fallback to direct eval to report syntax error.
*/
return TCL_ERROR;
}
if (parsePtr->numWords == 2) {
PUSH("1.0");
}
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;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/