diff options
Diffstat (limited to 'generic/tclCompExpr.c')
| -rw-r--r-- | generic/tclCompExpr.c | 2592 |
1 files changed, 623 insertions, 1969 deletions
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 6bae02b..1f57c03 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -3,12 +3,12 @@ * * This file contains the code to compile Tcl expressions. * - * Copyright (c) 1996-1997 Sun Microsystems, Inc. + * Copyright (c) 1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclCompExpr.c 1.34 97/11/03 14:29:18 + * SCCS: @(#) tclCompExpr.c 1.43 98/02/06 15:19:04 */ #include "tclInt.h" @@ -37,7 +37,7 @@ extern int errno; /* Use errno from tclExecute.c. */ */ #ifdef TCL_COMPILE_DEBUG -static int traceCompileExpr = 0; +static int traceExprComp = 0; #endif /* TCL_COMPILE_DEBUG */ /* @@ -47,21 +47,12 @@ static int traceCompileExpr = 0; */ typedef struct ExprInfo { - int token; /* Type of the last token parsed in expr. - * See below for definitions. Corresponds - * to the characters just before next. */ - int objIndex; /* If token is a literal value, the index of - * an object holding the value in the code's - * object table; otherwise is NULL. */ - char *funcName; /* If the token is FUNC_NAME, points to the - * first character of the math function's - * name; otherwise is NULL. */ - char *next; /* Position of the next character to be - * scanned in the expression string. */ - char *originalExpr; /* The entire expression that was originally - * passed to Tcl_ExprString et al. */ - char *lastChar; /* Pointer to terminating null in - * originalExpr. */ + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Structure filled with information about + * the parsed expression. */ + char *expr; /* The expression that was originally passed + * to TclCompileExpr. */ + char *lastChar; /* Points just after last byte of expr. */ int hasOperators; /* Set 1 if the expr has operators; 0 if * expr is only a primary. If 1 after * compiling an expr, a tryCvtToNumeric @@ -82,135 +73,115 @@ typedef struct ExprInfo { } ExprInfo; /* - * Definitions of the different tokens that appear in expressions. The order - * of these must match the corresponding entries in the operatorStrings - * array below. + * Definitions of numeric codes representing each expression operator. + * The order of these must match the entries in the operatorTable below. + * Also the codes for the relational operators (OP_LESS, OP_GREATER, + * OP_LE, OP_GE, OP_EQ, and OP_NE) must be consecutive and in that order. + * Note that OP_PLUS and OP_MINUS represent both unary and binary operators. */ -#define LITERAL 0 -#define FUNC_NAME (LITERAL + 1) -#define OPEN_BRACKET (LITERAL + 2) -#define CLOSE_BRACKET (LITERAL + 3) -#define OPEN_PAREN (LITERAL + 4) -#define CLOSE_PAREN (LITERAL + 5) -#define DOLLAR (LITERAL + 6) -#define QUOTE (LITERAL + 7) -#define COMMA (LITERAL + 8) -#define END (LITERAL + 9) -#define UNKNOWN (LITERAL + 10) +#define OP_MULT 0 +#define OP_DIVIDE 1 +#define OP_MOD 2 +#define OP_PLUS 3 +#define OP_MINUS 4 +#define OP_LSHIFT 5 +#define OP_RSHIFT 6 +#define OP_LESS 7 +#define OP_GREATER 8 +#define OP_LE 9 +#define OP_GE 10 +#define OP_EQ 11 +#define OP_NEQ 12 +#define OP_BITAND 13 +#define OP_BITXOR 14 +#define OP_BITOR 15 +#define OP_LAND 16 +#define OP_LOR 17 +#define OP_QUESTY 18 +#define OP_LNOT 19 +#define OP_BITNOT 20 /* - * Binary operators: + * Table describing the expression operators. Entries in this table must + * correspond to the definitions of numeric codes for operators just above. */ -#define MULT (UNKNOWN + 1) -#define DIVIDE (MULT + 1) -#define MOD (MULT + 2) -#define PLUS (MULT + 3) -#define MINUS (MULT + 4) -#define LEFT_SHIFT (MULT + 5) -#define RIGHT_SHIFT (MULT + 6) -#define LESS (MULT + 7) -#define GREATER (MULT + 8) -#define LEQ (MULT + 9) -#define GEQ (MULT + 10) -#define EQUAL (MULT + 11) -#define NEQ (MULT + 12) -#define BIT_AND (MULT + 13) -#define BIT_XOR (MULT + 14) -#define BIT_OR (MULT + 15) -#define AND (MULT + 16) -#define OR (MULT + 17) -#define QUESTY (MULT + 18) -#define COLON (MULT + 19) - -/* - * Unary operators. Unary minus and plus are represented by the (binary) - * tokens MINUS and PLUS. - */ - -#define NOT (COLON + 1) -#define BIT_NOT (NOT + 1) +static int opTableInitialized = 0; /* 0 means not yet initialized. */ +static Tcl_Mutex opMutex; + +typedef struct OperatorDesc { + char *name; /* Name of the operator. */ + int numOperands; /* Number of operands. 0 if the operator + * requires special handling. */ + int instruction; /* Instruction opcode for the operator. + * Ignored if numOperands is 0. */ +} OperatorDesc; + +OperatorDesc operatorTable[] = { + {"*", 2, INST_MULT}, + {"/", 2, INST_DIV}, + {"%", 2, INST_MOD}, + {"+", 0}, + {"-", 0}, + {"<<", 2, INST_LSHIFT}, + {">>", 2, INST_RSHIFT}, + {"<", 2, INST_LT}, + {">", 2, INST_GT}, + {"<=", 2, INST_LE}, + {">=", 2, INST_GE}, + {"==", 2, INST_EQ}, + {"!=", 2, INST_NEQ}, + {"&", 2, INST_BITAND}, + {"^", 2, INST_BITXOR}, + {"|", 2, INST_BITOR}, + {"&&", 0}, + {"||", 0}, + {"?", 0}, + {"!", 1, INST_LNOT}, + {"~", 1, INST_BITNOT}, + {NULL} +}; /* - * Mapping from tokens to strings; used for debugging messages. These - * entries must match the order and number of the token definitions above. + * Hashtable used to map the names of expression operators to the index + * of their OperatorDesc description. */ -#ifdef TCL_COMPILE_DEBUG -static char *tokenStrings[] = { - "LITERAL", "FUNCNAME", - "[", "]", "(", ")", "$", "\"", ",", "END", "UNKNOWN", - "*", "/", "%", "+", "-", - "<<", ">>", "<", ">", "<=", ">=", "==", "!=", - "&", "^", "|", "&&", "||", "?", ":", - "!", "~" -}; -#endif /* TCL_COMPILE_DEBUG */ +static Tcl_HashTable opHashTable; /* * Declarations for local procedures to this file: */ -static int CompileAddExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileBitAndExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileBitOrExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileBitXorExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileCondExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileEqualityExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, +static int CompileCondExpr _ANSI_ARGS_(( + Tcl_Token *exprTokenPtr, ExprInfo *infoPtr, + CompileEnv *envPtr, Tcl_Token **endPtrPtr)); +static int CompileLandOrLorExpr _ANSI_ARGS_(( + Tcl_Token *exprTokenPtr, int opIndex, + ExprInfo *infoPtr, CompileEnv *envPtr, + Tcl_Token **endPtrPtr)); +static int CompileMathFuncCall _ANSI_ARGS_(( + Tcl_Token *exprTokenPtr, char *funcName, + ExprInfo *infoPtr, CompileEnv *envPtr, + Tcl_Token **endPtrPtr)); +static int CompileSubExpr _ANSI_ARGS_(( + Tcl_Token *exprTokenPtr, ExprInfo *infoPtr, CompileEnv *envPtr)); -static int CompileLandExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileLorExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileMathFuncCall _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileMultiplyExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompilePrimaryExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileRelationalExpr _ANSI_ARGS_(( - Tcl_Interp *interp, ExprInfo *infoPtr, - int flags, CompileEnv *envPtr)); -static int CompileShiftExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileUnaryExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int GetToken _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, CompileEnv *envPtr)); +static void LogSyntaxError _ANSI_ARGS_((ExprInfo *infoPtr)); /* - * Macro used to debug the execution of the recursive descent parser used - * to compile expressions. + * Macro used to debug the execution of the expression compiler. */ #ifdef TCL_COMPILE_DEBUG -#define HERE(production, level) \ - if (traceCompileExpr) { \ - fprintf(stderr, "%*s%s: token=%s, next=\"%.20s\"\n", \ - (level), " ", (production), tokenStrings[infoPtr->token], \ - infoPtr->next); \ +#define TRACE(exprBytes, exprLength, tokenBytes, tokenLength) \ + if (traceExprComp) { \ + fprintf(stderr, "CompileSubExpr: \"%.*s\", token \"%.*s\"\n", \ + (exprLength), (exprBytes), (tokenLength), (tokenBytes)); \ } #else -#define HERE(production, level) +#define TRACE(exprBytes, exprLength, tokenBytes, tokenLength) #endif /* TCL_COMPILE_DEBUG */ /* @@ -224,23 +195,11 @@ static int GetToken _ANSI_ARGS_((Tcl_Interp *interp, * procedures as Tcl_ExprString, Tcl_ExprStringObj, Tcl_ExprLong, * Tcl_ExprDouble, Tcl_ExprBoolean, and Tcl_ExprBooleanObj. * - * Note that the topmost recursive-descent parsing routine used by - * TclCompileExpr to compile expressions is called "CompileCondExpr" - * and not, e.g., "CompileExpr". This is done to avoid an extra - * procedure call since such a procedure would only return the result - * of calling CompileCondExpr. Other recursive-descent procedures - * that need to parse expressions also call CompileCondExpr. - * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR * on failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed; this might - * be the offset of the ']' (if flags & TCL_BRACKET_TERM), or the - * offset of the '\0' at the end of the string. - * * envPtr->maxStackDepth is updated with the maximum number of stack * elements needed to execute the expression. * @@ -261,85 +220,73 @@ static int GetToken _ANSI_ARGS_((Tcl_Interp *interp, */ int -TclCompileExpr(interp, string, lastChar, flags, envPtr) +TclCompileExpr(interp, script, numBytes, envPtr) Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ + char *script; /* The source script to compile. */ + int numBytes; /* Number of bytes in script. If < 0, the + * string consists of all bytes up to the + * first null character. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { - Interp *iPtr = (Interp *) interp; ExprInfo info; - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int result; - -#ifdef TCL_COMPILE_DEBUG - if (traceCompileExpr) { - fprintf(stderr, "expr: string=\"%.30s\"\n", string); - } -#endif /* TCL_COMPILE_DEBUG */ + Tcl_Parse parse; + Tcl_HashEntry *hPtr; + int maxDepth, new, i, code; /* - * Register the builtin math functions the first time an expression is - * compiled. + * If this is the first time we've been called, initialize the table + * of expression operators. */ - if (!(iPtr->flags & EXPR_INITIALIZED)) { - BuiltinFunc *funcPtr; - Tcl_HashEntry *hPtr; - MathFunc *mathFuncPtr; - int i; - - iPtr->flags |= EXPR_INITIALIZED; - i = 0; - for (funcPtr = builtinFuncTable; funcPtr->name != NULL; funcPtr++) { - Tcl_CreateMathFunc(interp, funcPtr->name, - funcPtr->numArgs, funcPtr->argTypes, - (Tcl_MathProc *) NULL, (ClientData) 0); - - hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcPtr->name); - if (hPtr == NULL) { - panic("TclCompileExpr: Tcl_CreateMathFunc incorrectly registered '%s'", funcPtr->name); - return TCL_ERROR; + if (numBytes < 0) { + numBytes = (script? strlen(script) : 0); + } + if (!opTableInitialized) { + Tcl_MutexLock(&opMutex); + if (!opTableInitialized) { + Tcl_InitHashTable(&opHashTable, TCL_STRING_KEYS); + for (i = 0; operatorTable[i].name != NULL; i++) { + hPtr = Tcl_CreateHashEntry(&opHashTable, + operatorTable[i].name, &new); + if (new) { + Tcl_SetHashValue(hPtr, (ClientData) i); + } } - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - mathFuncPtr->builtinFuncIndex = i; - i++; + opTableInitialized = 1; } + Tcl_MutexUnlock(&opMutex); } - info.token = UNKNOWN; - info.objIndex = -1; - info.funcName = NULL; - info.next = string; - info.originalExpr = string; - info.lastChar = lastChar; + /* + * Initialize the structure containing information abvout this + * expression compilation. + */ + + info.interp = interp; + info.parsePtr = &parse; + info.expr = script; + info.lastChar = (script + numBytes); info.hasOperators = 0; info.exprIsJustVarRef = 1; /* will be set 0 if anything else is seen */ - info.exprIsComparison = 0; /* set 1 if topmost operator is <,==,etc. */ + info.exprIsComparison = 0; /* - * Get the first token then compile an expression. + * Parse the expression then compile it. */ - result = GetToken(interp, &info, envPtr); - if (result != TCL_OK) { - goto done; - } - - result = CompileCondExpr(interp, &info, flags, envPtr); - if (result != TCL_OK) { + maxDepth = 0; + code = Tcl_ParseExpr(interp, script, numBytes, &parse); + if (code != TCL_OK) { goto done; } - if (info.token != END) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "syntax error in expression \"", string, "\"", (char *) NULL); - result = TCL_ERROR; + + code = CompileSubExpr(parse.tokenPtr, &info, envPtr); + if (code != TCL_OK) { + Tcl_FreeParse(&parse); goto done; } + maxDepth = envPtr->maxStackDepth; + if (!info.hasOperators) { /* * Attempt to convert the primary's object to an int or double. @@ -350,186 +297,54 @@ TclCompileExpr(interp, string, lastChar, flags, envPtr) TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); } - maxDepth = envPtr->maxStackDepth; + Tcl_FreeParse(&parse); done: - envPtr->termOffset = (info.next - string); envPtr->maxStackDepth = maxDepth; envPtr->exprIsJustVarRef = info.exprIsJustVarRef; envPtr->exprIsComparison = info.exprIsComparison; - return result; + return code; } /* *---------------------------------------------------------------------- * - * CompileCondExpr -- + * TclFinalizeCompilation -- * - * This procedure compiles a Tcl conditional expression: - * condExpr ::= lorExpr ['?' condExpr ':' condExpr] - * - * Note that this is the topmost recursive-descent parsing routine used - * by TclCompileExpr to compile expressions. It does not call an - * separate, higher-level "CompileExpr" procedure. This avoids an extra - * procedure call since such a procedure would only return the result - * of calling CompileCondExpr. Other recursive-descent procedures that - * need to parse expressions also call CompileCondExpr. + * Clean up the compilation environment so it can later be + * properly reinitialized. This procedure is called by + * TclFinalizeCompExecEnv() in tclObj.c, which in turn is called + * by Tcl_Finalize(). * * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. + * None. * * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. + * Cleans up the compilation environment. At the moment, just the + * table of expression operators is freed. * *---------------------------------------------------------------------- */ -static int -CompileCondExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +void +TclFinalizeCompilation() { - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - JumpFixup jumpAroundThenFixup, jumpAroundElseFixup; - /* Used to update or replace one-byte jumps - * around the then and else expressions when - * their target PCs are determined. */ - int elseCodeOffset, currCodeOffset, jumpDist, result; - - HERE("condExpr", 1); - result = CompileLorExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - - if (infoPtr->token == QUESTY) { - result = GetToken(interp, infoPtr, envPtr); /* skip over the '?' */ - if (result != TCL_OK) { - goto done; - } - - /* - * Emit the jump around the "then" clause to the "else" condExpr if - * the test was false. We emit a one byte (relative) jump here, and - * replace it later with a four byte jump if the jump target is more - * than 127 bytes away. - */ - - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpAroundThenFixup); - - /* - * Compile the "then" expression. Note that if a subexpression - * is only a primary, we need to try to convert it to numeric. - * This is done in order to support Tcl's policy of interpreting - * operands if at all possible as first integers, else - * floating-point numbers. - */ - - infoPtr->hasOperators = 0; - infoPtr->exprIsJustVarRef = 0; - infoPtr->exprIsComparison = 0; - result = CompileCondExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - if (infoPtr->token != COLON) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "syntax error in expression \"", infoPtr->originalExpr, - "\"", (char *) NULL); - result = TCL_ERROR; - goto done; - } - if (!infoPtr->hasOperators) { - TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); - } - result = GetToken(interp, infoPtr, envPtr); /* skip over the ':' */ - if (result != TCL_OK) { - goto done; - } - - /* - * Emit an unconditional jump around the "else" condExpr. - */ - - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpAroundElseFixup); - - /* - * Compile the "else" expression. - */ - - infoPtr->hasOperators = 0; - elseCodeOffset = TclCurrCodeOffset(); - result = CompileCondExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - if (!infoPtr->hasOperators) { - TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); - } - - /* - * Fix up the second jump: the unconditional jump around the "else" - * expression. If the distance is too great (> 127 bytes), replace - * it with a four byte instruction and move the instructions after - * the jump down. - */ - - currCodeOffset = TclCurrCodeOffset(); - jumpDist = (currCodeOffset - jumpAroundElseFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpAroundElseFixup, jumpDist, 127)) { - /* - * Update the else expression's starting code offset since it - * moved down 3 bytes too. - */ - - elseCodeOffset += 3; - } - - /* - * Now fix up the first branch: the jumpFalse after the test. If the - * distance is too great, replace it with a four byte instruction - * and update the code offsets for the commands in both the "then" - * and "else" expressions. - */ - - jumpDist = (elseCodeOffset - jumpAroundThenFixup.codeOffset); - TclFixupForwardJump(envPtr, &jumpAroundThenFixup, jumpDist, 127); - - infoPtr->hasOperators = 1; - - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; + Tcl_MutexLock(&opMutex); + if (opTableInitialized) { + Tcl_DeleteHashTable(&opHashTable); + opTableInitialized = 0; } - - done: - envPtr->maxStackDepth = maxDepth; - return result; + Tcl_MutexUnlock(&opMutex); } /* *---------------------------------------------------------------------- * - * CompileLorExpr -- + * CompileSubExpr -- * - * This procedure compiles a Tcl logical or expression: - * lorExpr ::= landExpr {'||' landExpr} + * Given a pointer to a TCL_TOKEN_SUB_EXPR token describing a + * subexpression, this procedure emits instructions to evaluate the + * subexpression at runtime. * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR @@ -537,408 +352,295 @@ CompileCondExpr(interp, infoPtr, flags, envPtr) * contains an error message. * * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. + * elements needed to execute the subexpression. + * + * envPtr->exprIsJustVarRef is set 1 if the subexpression consisted of + * a single variable reference as in the expression of "if $b then...". + * Otherwise it is set 0. This is used to implement Tcl's two level + * expression substitution semantics properly. + * + * envPtr->exprIsComparison is set 1 if the top-level operator in the + * subexpression is a comparison. Otherwise it is set 0. If 1, because + * the operands might be strings, the expr is compiled out-of-line in + * order to implement expr's 2 level substitution semantics properly. * * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. + * Adds instructions to envPtr to evaluate the subexpression. * *---------------------------------------------------------------------- */ static int -CompileLorExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ +CompileSubExpr(exprTokenPtr, infoPtr, envPtr) + Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token + * to compile. */ ExprInfo *infoPtr; /* Describes the compilation state for the * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ CompileEnv *envPtr; /* Holds resulting instructions. */ { - int maxDepth; /* Maximum number of stack elements needed - * to execute the expression. */ - JumpFixupArray jumpFixupArray; - /* Used to fix up the forward "short - * circuit" jump after each or-ed - * subexpression to just after the last - * subexpression. */ - JumpFixup jumpTrueFixup, jumpFixup; - /* Used to emit the jumps in the code to - * convert the first operand to a 0 or 1. */ - int fixupIndex, jumpDist, currCodeOffset, objIndex, j, result; - Tcl_Obj *objPtr; - - HERE("lorExpr", 2); - result = CompileLandExpr(interp, infoPtr, flags, envPtr); - if ((result != TCL_OK) || (infoPtr->token != OR)) { - return result; /* envPtr->maxStackDepth is already set */ - } - - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - maxDepth = envPtr->maxStackDepth; - TclInitJumpFixupArray(&jumpFixupArray); - while (infoPtr->token == OR) { - result = GetToken(interp, infoPtr, envPtr); /* skip over the '||' */ - if (result != TCL_OK) { - goto done; - } + Tcl_Interp *interp = infoPtr->interp; + Tcl_Token *tokenPtr, *endPtr, *afterSubexprPtr; + OperatorDesc *opDescPtr; + Tcl_HashEntry *hPtr; + char *operator; + char savedChar; + int maxDepth, objIndex, opIndex, length, code; + char buffer[TCL_UTF_MAX]; - if (jumpFixupArray.next == 0) { - /* - * Just the first "lor" operand is on the stack. The following - * is slightly ugly: we need to convert that first "lor" operand - * to a "0" or "1" to get the correct result if it is nonzero. - * Eventually we'll use a new instruction for this. - */ + if (exprTokenPtr->type != TCL_TOKEN_SUB_EXPR) { + panic("CompileSubExpr: token type %d not TCL_TOKEN_SUB_EXPR\n", + exprTokenPtr->type); + } + maxDepth = 0; + code = TCL_OK; - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpTrueFixup); + /* + * Switch on the type of the first token after the subexpression token. + * After processing it, advance tokenPtr to point just after the + * subexpression's last token. + */ + + tokenPtr = exprTokenPtr+1; + TRACE(exprTokenPtr->start, exprTokenPtr->size, + tokenPtr->start, tokenPtr->size); + switch (tokenPtr->type) { + case TCL_TOKEN_WORD: + code = TclCompileTokens(interp, tokenPtr+1, + tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr += (tokenPtr->numComponents + 1); + infoPtr->exprIsJustVarRef = 0; + break; - objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; - - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = 0; - objPtr->typePtr = &tclIntType; + case TCL_TOKEN_TEXT: + if (tokenPtr->size > 0) { + objIndex = TclRegisterLiteral(envPtr, tokenPtr->start, + tokenPtr->size, /*onHeap*/ 0); + } else { + objIndex = TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0); + } + TclEmitPush(objIndex, envPtr); + maxDepth = 1; + tokenPtr += 1; + infoPtr->exprIsJustVarRef = 0; + break; + case TCL_TOKEN_BS: + length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, + buffer); + if (length > 0) { + objIndex = TclRegisterLiteral(envPtr, buffer, length, + /*onHeap*/ 0); + } else { + objIndex = TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0); + } TclEmitPush(objIndex, envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - - jumpDist = (TclCurrCodeOffset() - jumpTrueFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpTrueFixup, jumpDist, 127)) { - panic("CompileLorExpr: bad jump distance %d\n", jumpDist); + maxDepth = 1; + tokenPtr += 1; + infoPtr->exprIsJustVarRef = 0; + break; + + case TCL_TOKEN_COMMAND: + code = TclCompileScript(interp, tokenPtr->start+1, + tokenPtr->size-2, /*nested*/ 1, envPtr); + if (code != TCL_OK) { + goto done; } - objIndex = TclObjIndexForString("1", 1, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; - - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = 1; - objPtr->typePtr = &tclIntType; + maxDepth = envPtr->maxStackDepth; + tokenPtr += 1; + infoPtr->exprIsJustVarRef = 0; + break; - TclEmitPush(objIndex, envPtr); - - jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { - panic("CompileLorExpr: bad jump distance %d\n", jumpDist); + case TCL_TOKEN_VARIABLE: + code = TclCompileTokens(interp, tokenPtr, 1, envPtr); + if (code != TCL_OK) { + goto done; } - } - - /* - * Duplicate the value on top of the stack to prevent the jump from - * consuming it. - */ - - TclEmitOpcode(INST_DUP, envPtr); - - /* - * Emit the "short circuit" jump around the rest of the lorExp if - * the previous expression was true. We emit a one byte (relative) - * jump here, and replace it later with a four byte jump if the jump - * target is more than 127 bytes away. - */ - - if (jumpFixupArray.next == jumpFixupArray.end) { - TclExpandJumpFixupArray(&jumpFixupArray); - } - fixupIndex = jumpFixupArray.next; - jumpFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, - &(jumpFixupArray.fixup[fixupIndex])); - - /* - * Compile the subexpression. - */ - - result = CompileLandExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - /* - * Emit a "logical or" instruction. This does not try to "short- - * circuit" the evaluation of both operands of a Tcl "||" operator, - * but instead ensures that we either have a "1" or a "0" result. - */ - - TclEmitOpcode(INST_LOR, envPtr); - } - - /* - * Now that we know the target of the forward jumps, update the jumps - * with the correct distance. Also, if the distance is too great (> 127 - * bytes), replace the jump with a four byte instruction and move the - * instructions after the jump down. - */ - - for (j = jumpFixupArray.next; j > 0; j--) { - fixupIndex = (j - 1); /* process closest jump first */ - currCodeOffset = TclCurrCodeOffset(); - jumpDist = (currCodeOffset - jumpFixupArray.fixup[fixupIndex].codeOffset); - TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]), jumpDist, 127); - } - - /* - * We get here only if one or more ||'s appear as top-level operators. - */ - - done: - infoPtr->exprIsComparison = 0; - TclFreeJumpFixupArray(&jumpFixupArray); - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileLandExpr -- - * - * This procedure compiles a Tcl logical and expression: - * landExpr ::= bitOrExpr {'&&' bitOrExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileLandExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth; /* Maximum number of stack elements needed - * to execute the expression. */ - JumpFixupArray jumpFixupArray; - /* Used to fix up the forward "short - * circuit" jump after each and-ed - * subexpression to just after the last - * subexpression. */ - JumpFixup jumpTrueFixup, jumpFixup; - /* Used to emit the jumps in the code to - * convert the first operand to a 0 or 1. */ - int fixupIndex, jumpDist, currCodeOffset, objIndex, j, result; - Tcl_Obj *objPtr; - - HERE("landExpr", 3); - result = CompileBitOrExpr(interp, infoPtr, flags, envPtr); - if ((result != TCL_OK) || (infoPtr->token != AND)) { - return result; /* envPtr->maxStackDepth is already set */ - } - - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - maxDepth = envPtr->maxStackDepth; - TclInitJumpFixupArray(&jumpFixupArray); - while (infoPtr->token == AND) { - result = GetToken(interp, infoPtr, envPtr); /* skip over the '&&' */ - if (result != TCL_OK) { - goto done; - } - - if (jumpFixupArray.next == 0) { - /* - * Just the first "land" operand is on the stack. The following - * is slightly ugly: we need to convert the first "land" operand - * to a "0" or "1" to get the correct result if it is - * nonzero. Eventually we'll use a new instruction. - */ - - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpTrueFixup); - - objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; - - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = 0; - objPtr->typePtr = &tclIntType; + maxDepth = envPtr->maxStackDepth; + tokenPtr += (tokenPtr->numComponents + 1); + break; - TclEmitPush(objIndex, envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - - jumpDist = (TclCurrCodeOffset() - jumpTrueFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpTrueFixup, jumpDist, 127)) { - panic("CompileLandExpr: bad jump distance %d\n", jumpDist); + case TCL_TOKEN_SUB_EXPR: + infoPtr->exprIsComparison = 0; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; } - objIndex = TclObjIndexForString("1", 1, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; - - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = 1; - objPtr->typePtr = &tclIntType; + maxDepth = envPtr->maxStackDepth; + tokenPtr += (tokenPtr->numComponents + 1); + break; - TclEmitPush(objIndex, envPtr); + case TCL_TOKEN_OPERATOR: + /* + * Look up the operator. Temporarily overwrite the character + * just after the end of the operator with a 0 byte. If the + * operator isn't found, treat it as a math function. + */ - jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { - panic("CompileLandExpr: bad jump distance %d\n", jumpDist); + operator = tokenPtr->start; + savedChar = operator[tokenPtr->size]; + operator[tokenPtr->size] = 0; + hPtr = Tcl_FindHashEntry(&opHashTable, operator); + if (hPtr == NULL) { + code = CompileMathFuncCall(exprTokenPtr, operator, infoPtr, + envPtr, &endPtr); + operator[tokenPtr->size] = (char) savedChar; + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr = endPtr; + infoPtr->exprIsJustVarRef = 0; + infoPtr->exprIsComparison = 0; + break; } - } + operator[tokenPtr->size] = (char) savedChar; + opIndex = (int) Tcl_GetHashValue(hPtr); + opDescPtr = &(operatorTable[opIndex]); - /* - * Duplicate the value on top of the stack to prevent the jump from - * consuming it. - */ - - TclEmitOpcode(INST_DUP, envPtr); - - /* - * Emit the "short circuit" jump around the rest of the landExp if - * the previous expression was false. We emit a one byte (relative) - * jump here, and replace it later with a four byte jump if the jump - * target is more than 127 bytes away. - */ + /* + * If the operator is "normal", compile it using information + * from the operator table. + */ - if (jumpFixupArray.next == jumpFixupArray.end) { - TclExpandJumpFixupArray(&jumpFixupArray); - } - fixupIndex = jumpFixupArray.next; - jumpFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - &(jumpFixupArray.fixup[fixupIndex])); - - /* - * Compile the subexpression. - */ + if (opDescPtr->numOperands > 0) { + tokenPtr++; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr += (tokenPtr->numComponents + 1); - result = CompileBitOrExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + if (opDescPtr->numOperands == 2) { + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = TclMax((envPtr->maxStackDepth + 1), + maxDepth); + tokenPtr += (tokenPtr->numComponents + 1); + } + TclEmitOpcode(opDescPtr->instruction, envPtr); + infoPtr->hasOperators = 1; + infoPtr->exprIsJustVarRef = 0; + infoPtr->exprIsComparison = + ((opIndex >= OP_LESS) && (opIndex <= OP_NEQ)); + break; + } + + /* + * The operator requires special treatment, and is either + * "+" or "-", or one of "&&", "||" or "?". + */ + + switch (opIndex) { + case OP_PLUS: + case OP_MINUS: + tokenPtr++; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr += (tokenPtr->numComponents + 1); + + /* + * Check whether the "+" or "-" is unary. + */ + + afterSubexprPtr = exprTokenPtr + + exprTokenPtr->numComponents+1; + if (tokenPtr == afterSubexprPtr) { + TclEmitOpcode(((opIndex==OP_PLUS)? + INST_UPLUS : INST_UMINUS), + envPtr); + break; + } + + /* + * The "+" or "-" is binary. + */ + + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = TclMax((envPtr->maxStackDepth + 1), + maxDepth); + tokenPtr += (tokenPtr->numComponents + 1); + TclEmitOpcode(((opIndex==OP_PLUS)? INST_ADD : INST_SUB), + envPtr); + break; - /* - * Emit a "logical and" instruction. This does not try to "short- - * circuit" the evaluation of both operands of a Tcl "&&" operator, - * but instead ensures that we either have a "1" or a "0" result. - */ + case OP_LAND: + case OP_LOR: + code = CompileLandOrLorExpr(exprTokenPtr, opIndex, + infoPtr, envPtr, &endPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr = endPtr; + break; + + case OP_QUESTY: + code = CompileCondExpr(exprTokenPtr, infoPtr, + envPtr, &endPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr = endPtr; + break; + + default: + panic("CompileSubExpr: unexpected operator %d requiring special treatment\n", + opIndex); + } /* end switch on operator requiring special treatment */ + infoPtr->hasOperators = 1; + infoPtr->exprIsJustVarRef = 0; + infoPtr->exprIsComparison = 0; + break; - TclEmitOpcode(INST_LAND, envPtr); + default: + panic("CompileSubExpr: unexpected token type %d\n", + tokenPtr->type); } /* - * Now that we know the target of the forward jumps, update the jumps - * with the correct distance. Also, if the distance is too great (> 127 - * bytes), replace the jump with a four byte instruction and move the - * instructions after the jump down. + * Verify that the subexpression token had the required number of + * subtokens: that we've advanced tokenPtr just beyond the + * subexpression's last token. For example, a "*" subexpression must + * contain the tokens for exactly two operands. */ - for (j = jumpFixupArray.next; j > 0; j--) { - fixupIndex = (j - 1); /* process closest jump first */ - currCodeOffset = TclCurrCodeOffset(); - jumpDist = (currCodeOffset - jumpFixupArray.fixup[fixupIndex].codeOffset); - TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]), - jumpDist, 127); - } - - /* - * We get here only if one or more &&'s appear as top-level operators. - */ - - done: - infoPtr->exprIsComparison = 0; - TclFreeJumpFixupArray(&jumpFixupArray); - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileBitOrExpr -- - * - * This procedure compiles a Tcl bitwise or expression: - * bitOrExpr ::= bitXorExpr {'|' bitXorExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileBitOrExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int result; - - HERE("bitOrExpr", 4); - result = CompileBitXorExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; + if (tokenPtr != (exprTokenPtr + exprTokenPtr->numComponents+1)) { + LogSyntaxError(infoPtr); + code = TCL_ERROR; } - maxDepth = envPtr->maxStackDepth; - while (infoPtr->token == BIT_OR) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over the '|' */ - if (result != TCL_OK) { - goto done; - } - - result = CompileBitXorExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - TclEmitOpcode(INST_BITOR, envPtr); - - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; - } - done: envPtr->maxStackDepth = maxDepth; - return result; + return code; } /* *---------------------------------------------------------------------- * - * CompileBitXorExpr -- + * CompileLandOrLorExpr -- * - * This procedure compiles a Tcl bitwise exclusive or expression: - * bitXorExpr ::= bitAndExpr {'^' bitAndExpr} + * This procedure compiles a Tcl logical and ("&&") or logical or + * ("||") subexpression. * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * on failure. If TCL_OK is returned, a pointer to the token just after + * the last one in the subexpression is stored at the address in + * endPtrPtr. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * envPtr->maxStackDepth is updated with the maximum number of stack @@ -951,297 +653,116 @@ CompileBitOrExpr(interp, infoPtr, flags, envPtr) */ static int -CompileBitXorExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, endPtrPtr) + Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token + * containing the "&&" or "||" operator. */ + int opIndex; /* A code describing the expression + * operator: either OP_LAND or OP_LOR. */ + ExprInfo *infoPtr; /* Describes the compilation state for the + * expression being compiled. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ + Tcl_Token **endPtrPtr; /* If successful, a pointer to the token + * just after the last token in the + * subexpression is stored here. */ { - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int result; - - HERE("bitXorExpr", 5); - result = CompileBitAndExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - - while (infoPtr->token == BIT_XOR) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over the '^' */ - if (result != TCL_OK) { - goto done; - } - - result = CompileBitAndExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - TclEmitOpcode(INST_BITXOR, envPtr); - - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; - } - - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileBitAndExpr -- - * - * This procedure compiles a Tcl bitwise and expression: - * bitAndExpr ::= equalityExpr {'&' equalityExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ + JumpFixup shortCircuitFixup; /* Used to fix up the short circuit jump + * after the first subexpression. */ + JumpFixup lhsTrueFixup, lhsEndFixup; + /* Used to fix up jumps used to convert the + * first operand to 0 or 1. */ + Tcl_Token *tokenPtr; + int dist, maxDepth, code; -static int -CompileBitAndExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int result; + /* + * Emit code for the first operand. + */ - HERE("bitAndExpr", 6); - result = CompileEqualityExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { + maxDepth = 0; + tokenPtr = exprTokenPtr+2; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { goto done; } maxDepth = envPtr->maxStackDepth; - - while (infoPtr->token == BIT_AND) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over the '&' */ - if (result != TCL_OK) { - goto done; - } - - result = CompileEqualityExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - TclEmitOpcode(INST_BITAND, envPtr); - - /* - * A comparison is not the top-level operator in this expression. - */ + tokenPtr += (tokenPtr->numComponents + 1); - infoPtr->exprIsComparison = 0; + /* + * Convert the first operand to the result that Tcl requires: + * "0" or "1". Eventually we'll use a new instruction for this. + */ + + TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &lhsTrueFixup); + TclEmitPush(TclRegisterLiteral(envPtr, "0", 1, /*onHeap*/ 0), envPtr); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &lhsEndFixup); + dist = (envPtr->codeNext - envPtr->codeStart) - lhsTrueFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &lhsTrueFixup, dist, 127)) { + badDist: + panic("CompileLandOrLorExpr: bad jump distance %d\n", dist); } - - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileEqualityExpr -- - * - * This procedure compiles a Tcl equality (inequality) expression: - * equalityExpr ::= relationalExpr {('==' | '!=') relationalExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileEqualityExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; - - HERE("equalityExpr", 7); - result = CompileRelationalExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; + TclEmitPush(TclRegisterLiteral(envPtr, "1", 1, /*onHeap*/ 0), envPtr); + dist = (envPtr->codeNext - envPtr->codeStart) - lhsEndFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &lhsEndFixup, dist, 127)) { + goto badDist; } - maxDepth = envPtr->maxStackDepth; - - op = infoPtr->token; - while ((op == EQUAL) || (op == NEQ)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over == or != */ - if (result != TCL_OK) { - goto done; - } - - result = CompileRelationalExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - if (op == EQUAL) { - TclEmitOpcode(INST_EQ, envPtr); - } else { - TclEmitOpcode(INST_NEQ, envPtr); - } - - op = infoPtr->token; + /* + * Emit the "short circuit" jump around the rest of the expression. + * Duplicate the "0" or "1" on top of the stack first to keep the + * jump from consuming it. + */ - /* - * A comparison _is_ the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 1; - } + TclEmitOpcode(INST_DUP, envPtr); + TclEmitForwardJump(envPtr, + ((opIndex==OP_LAND)? TCL_FALSE_JUMP : TCL_TRUE_JUMP), + &shortCircuitFixup); - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileRelationalExpr -- - * - * This procedure compiles a Tcl relational expression: - * relationalExpr ::= shiftExpr {('<' | '>' | '<=' | '>=') shiftExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileRelationalExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; + /* + * Emit code for the second operand. + */ - HERE("relationalExpr", 8); - result = CompileShiftExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { goto done; } - maxDepth = envPtr->maxStackDepth; + maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + tokenPtr += (tokenPtr->numComponents + 1); - op = infoPtr->token; - while ((op == LESS) || (op == GREATER) || (op == LEQ) || (op == GEQ)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over the op */ - if (result != TCL_OK) { - goto done; - } - - result = CompileShiftExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + /* + * Emit a "logical and" or "logical or" instruction. This does not try + * to "short- circuit" the evaluation of both operands, but instead + * ensures that we either have a "1" or a "0" result. + */ - switch (op) { - case LESS: - TclEmitOpcode(INST_LT, envPtr); - break; - case GREATER: - TclEmitOpcode(INST_GT, envPtr); - break; - case LEQ: - TclEmitOpcode(INST_LE, envPtr); - break; - case GEQ: - TclEmitOpcode(INST_GE, envPtr); - break; - } + TclEmitOpcode(((opIndex==OP_LAND)? INST_LAND : INST_LOR), envPtr); - op = infoPtr->token; + /* + * Now that we know the target of the forward jump, update it with the + * correct distance. + */ - /* - * A comparison _is_ the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 1; - } + dist = (envPtr->codeNext - envPtr->codeStart) + - shortCircuitFixup.codeOffset; + TclFixupForwardJump(envPtr, &shortCircuitFixup, dist, 127); + *endPtrPtr = tokenPtr; done: envPtr->maxStackDepth = maxDepth; - return result; + return code; } /* *---------------------------------------------------------------------- * - * CompileShiftExpr -- + * CompileCondExpr -- * - * This procedure compiles a Tcl shift expression: - * shiftExpr ::= addExpr {('<<' | '>>') addExpr} + * This procedure compiles a Tcl conditional expression: + * condExpr ::= lorExpr ['?' condExpr ':' condExpr] * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * on failure. If TCL_OK is returned, a pointer to the token just after + * the last one in the subexpression is stored at the address in + * endPtrPtr. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * envPtr->maxStackDepth is updated with the maximum number of stack @@ -1254,456 +775,109 @@ CompileRelationalExpr(interp, infoPtr, flags, envPtr) */ static int -CompileShiftExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ +CompileCondExpr(exprTokenPtr, infoPtr, envPtr, endPtrPtr) + Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token + * containing the "?" operator. */ ExprInfo *infoPtr; /* Describes the compilation state for the * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ CompileEnv *envPtr; /* Holds resulting instructions. */ + Tcl_Token **endPtrPtr; /* If successful, a pointer to the token + * just after the last token in the + * subexpression is stored here. */ { - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; + JumpFixup jumpAroundThenFixup, jumpAroundElseFixup; + /* Used to update or replace one-byte jumps + * around the then and else expressions when + * their target PCs are determined. */ + Tcl_Token *tokenPtr; + int elseCodeOffset, dist, maxDepth, code; + + /* + * Emit code for the test. + */ - HERE("shiftExpr", 9); - result = CompileAddExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { + maxDepth = 0; + tokenPtr = exprTokenPtr+2; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { goto done; } maxDepth = envPtr->maxStackDepth; + tokenPtr += (tokenPtr->numComponents + 1); + + /* + * Emit the jump to the "else" expression if the test was false. + */ + + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpAroundThenFixup); - op = infoPtr->token; - while ((op == LEFT_SHIFT) || (op == RIGHT_SHIFT)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over << or >> */ - if (result != TCL_OK) { - goto done; - } - - result = CompileAddExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - if (op == LEFT_SHIFT) { - TclEmitOpcode(INST_LSHIFT, envPtr); - } else { - TclEmitOpcode(INST_RSHIFT, envPtr); - } - - op = infoPtr->token; - - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; - } - - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileAddExpr -- - * - * This procedure compiles a Tcl addition expression: - * addExpr ::= multiplyExpr {('+' | '-') multiplyExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileAddExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; + /* + * Compile the "then" expression. Note that if a subexpression is only + * a primary, we need to try to convert it to numeric. We do this to + * support Tcl's policy of interpreting operands if at all possible as + * first integers, else floating-point numbers. + */ - HERE("addExpr", 10); - result = CompileMultiplyExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { + infoPtr->hasOperators = 0; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { goto done; } - maxDepth = envPtr->maxStackDepth; - - op = infoPtr->token; - while ((op == PLUS) || (op == MINUS)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over + or - */ - if (result != TCL_OK) { - goto done; - } - - result = CompileMultiplyExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - if (op == PLUS) { - TclEmitOpcode(INST_ADD, envPtr); - } else { - TclEmitOpcode(INST_SUB, envPtr); - } - - op = infoPtr->token; - - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + tokenPtr += (tokenPtr->numComponents + 1); + if (!infoPtr->hasOperators) { + TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); } - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileMultiplyExpr -- - * - * This procedure compiles a Tcl multiply expression: - * multiplyExpr ::= unaryExpr {('*' | '/' | '%') unaryExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ + /* + * Emit an unconditional jump around the "else" condExpr. + */ + + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, + &jumpAroundElseFixup); -static int -CompileMultiplyExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; + /* + * Compile the "else" expression. + */ - HERE("multiplyExpr", 11); - result = CompileUnaryExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { + elseCodeOffset = (envPtr->codeNext - envPtr->codeStart); + infoPtr->hasOperators = 0; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { goto done; } - maxDepth = envPtr->maxStackDepth; - - op = infoPtr->token; - while ((op == MULT) || (op == DIVIDE) || (op == MOD)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over * or / */ - if (result != TCL_OK) { - goto done; - } - - result = CompileUnaryExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - if (op == MULT) { - TclEmitOpcode(INST_MULT, envPtr); - } else if (op == DIVIDE) { - TclEmitOpcode(INST_DIV, envPtr); - } else { - TclEmitOpcode(INST_MOD, envPtr); - } - - op = infoPtr->token; - - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; - } - - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileUnaryExpr -- - * - * This procedure compiles a Tcl unary expression: - * unaryExpr ::= ('+' | '-' | '~' | '!') unaryExpr | primaryExpr - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileUnaryExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; - - HERE("unaryExpr", 12); - op = infoPtr->token; - if ((op == PLUS) || (op == MINUS) || (op == BIT_NOT) || (op == NOT)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over the op */ - if (result != TCL_OK) { - goto done; - } - - result = CompileUnaryExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - - switch (op) { - case PLUS: - TclEmitOpcode(INST_UPLUS, envPtr); - break; - case MINUS: - TclEmitOpcode(INST_UMINUS, envPtr); - break; - case BIT_NOT: - TclEmitOpcode(INST_BITNOT, envPtr); - break; - case NOT: - TclEmitOpcode(INST_LNOT, envPtr); - break; - } - - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; - } else { /* must be a primaryExpr */ - result = CompilePrimaryExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + tokenPtr += (tokenPtr->numComponents + 1); + if (!infoPtr->hasOperators) { + TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); } - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompilePrimaryExpr -- - * - * This procedure compiles a Tcl primary expression: - * primaryExpr ::= literal | varReference | quotedString | - * '[' command ']' | mathFuncCall | '(' condExpr ')' - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompilePrimaryExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int theToken; - char *dollarPtr, *quotePtr, *cmdPtr, *termPtr; - int result = TCL_OK; - /* - * We emit tryCvtToNumeric instructions after most of these primary - * expressions in order to support Tcl's policy of interpreting operands - * as first integers if possible, otherwise floating-point numbers if - * possible. + * Fix up the second jump around the "else" expression. */ - HERE("primaryExpr", 13); - theToken = infoPtr->token; - - if ((theToken != DOLLAR) && (theToken != OPEN_PAREN)) { - infoPtr->exprIsJustVarRef = 0; - } - switch (theToken) { - case LITERAL: /* int, double, or string in braces */ - TclEmitPush(infoPtr->objIndex, envPtr); - maxDepth = 1; - break; - - case DOLLAR: /* $var variable reference */ - dollarPtr = (infoPtr->next - 1); - envPtr->pushSimpleWords = 1; - result = TclCompileDollarVar(interp, dollarPtr, - infoPtr->lastChar, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - infoPtr->next = (dollarPtr + envPtr->termOffset); - break; - - case QUOTE: /* quotedString */ - quotePtr = infoPtr->next; - envPtr->pushSimpleWords = 1; - result = TclCompileQuotes(interp, quotePtr, - infoPtr->lastChar, '"', flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - infoPtr->next = (quotePtr + envPtr->termOffset); - break; - - case OPEN_BRACKET: /* '[' command ']' */ - cmdPtr = infoPtr->next; - envPtr->pushSimpleWords = 1; - result = TclCompileString(interp, cmdPtr, - infoPtr->lastChar, (flags | TCL_BRACKET_TERM), envPtr); - if (result != TCL_OK) { - goto done; - } - termPtr = (cmdPtr + envPtr->termOffset); - if (*termPtr == ']') { - infoPtr->next = (termPtr + 1); /* advance over the ']'. */ - } else if (termPtr == infoPtr->lastChar) { - /* - * Missing ] at end of nested command. - */ - - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "missing close-bracket", -1); - result = TCL_ERROR; - goto done; - } else { - panic("CompilePrimaryExpr: unexpected termination char '%c' for nested command\n", *termPtr); - } - maxDepth = envPtr->maxStackDepth; - break; - - case FUNC_NAME: - result = CompileMathFuncCall(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - break; - - case OPEN_PAREN: - result = GetToken(interp, infoPtr, envPtr); /* skip over the '(' */ - if (result != TCL_OK) { - goto done; - } - infoPtr->exprIsComparison = 0; - result = CompileCondExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - if (infoPtr->token != CLOSE_PAREN) { - goto syntaxError; - } - break; - - default: - goto syntaxError; - } - - if (theToken != FUNC_NAME) { + dist = (envPtr->codeNext - envPtr->codeStart) + - jumpAroundElseFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &jumpAroundElseFixup, dist, 127)) { /* - * Advance to the next token before returning. + * Update the else expression's starting code offset since it + * moved down 3 bytes too. */ - result = GetToken(interp, infoPtr, envPtr); - if (result != TCL_OK) { - goto done; - } + elseCodeOffset += 3; } + + /* + * Fix up the first jump to the "else" expression if the test was false. + */ + + dist = (elseCodeOffset - jumpAroundThenFixup.codeOffset); + TclFixupForwardJump(envPtr, &jumpAroundThenFixup, dist, 127); + *endPtrPtr = tokenPtr; done: envPtr->maxStackDepth = maxDepth; - return result; - - syntaxError: - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "syntax error in expression \"", infoPtr->originalExpr, - "\"", (char *) NULL); - return TCL_ERROR; + return code; } /* @@ -1716,7 +890,9 @@ CompilePrimaryExpr(interp, infoPtr, flags, envPtr) * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * on failure. If TCL_OK is returned, a pointer to the token just after + * the last one in the subexpression is stored at the address in + * endPtrPtr. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * envPtr->maxStackDepth is updated with the maximum number of stack @@ -1730,58 +906,35 @@ CompilePrimaryExpr(interp, infoPtr, flags, envPtr) */ static int -CompileMathFuncCall(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ +CompileMathFuncCall(exprTokenPtr, funcName, infoPtr, envPtr, endPtrPtr) + Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token + * containing the math function call. */ + char *funcName; /* Name of the math function. */ ExprInfo *infoPtr; /* Describes the compilation state for the * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ CompileEnv *envPtr; /* Holds resulting instructions. */ + Tcl_Token **endPtrPtr; /* If successful, a pointer to the token + * just after the last token in the + * subexpression is stored here. */ { + Tcl_Interp *interp = infoPtr->interp; Interp *iPtr = (Interp *) interp; - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - MathFunc *mathFuncPtr; /* Info about math function. */ - int objIndex; /* The object array index for an object - * holding the function name if it is not - * builtin. */ + MathFunc *mathFuncPtr; Tcl_HashEntry *hPtr; - char *p, *funcName; - char savedChar; - int result, i; + Tcl_Token *tokenPtr, *afterSubexprPtr; + int maxDepth, code, i; /* - * infoPtr->funcName points to the first character of the math - * function's name. Look for the end of its name and look up the - * MathFunc record for the function. + * Look up the MathFunc record for the function. */ - funcName = p = infoPtr->funcName; - while (isalnum(UCHAR(*p)) || (*p == '_')) { - p++; - } - infoPtr->next = p; - - result = GetToken(interp, infoPtr, envPtr); /* skip over func name */ - if (result != TCL_OK) { - goto done; - } - if (infoPtr->token != OPEN_PAREN) { - goto syntaxError; - } - result = GetToken(interp, infoPtr, envPtr); /* skip over '(' */ - if (result != TCL_OK) { - goto done; - } - - savedChar = *p; - *p = 0; + code = TCL_OK; + maxDepth = 0; hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown math function \"", funcName, "\"", (char *) NULL); - result = TCL_ERROR; - *p = savedChar; + code = TCL_ERROR; goto done; } mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); @@ -1790,597 +943,98 @@ CompileMathFuncCall(interp, infoPtr, flags, envPtr) * If not a builtin function, push an object with the function's name. */ - if (mathFuncPtr->builtinFuncIndex < 0) { /* not builtin */ - objIndex = TclObjIndexForString(funcName, -1, /*allocStrRep*/ 1, - /*inHeap*/ 0, envPtr); - TclEmitPush(objIndex, envPtr); + if (mathFuncPtr->builtinFuncIndex < 0) { + TclEmitPush(TclRegisterLiteral(envPtr, funcName, -1, /*onHeap*/ 0), + envPtr); maxDepth = 1; } /* - * Restore the saved character after the function name. - */ - - *p = savedChar; - - /* - * Compile the arguments for the function, if there are any. + * Compile any arguments for the function. */ + tokenPtr = exprTokenPtr+2; + afterSubexprPtr = exprTokenPtr + (exprTokenPtr->numComponents + 1); if (mathFuncPtr->numArgs > 0) { - for (i = 0; ; i++) { - infoPtr->exprIsComparison = 0; - result = CompileCondExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { + for (i = 0; i < mathFuncPtr->numArgs; i++) { + if (tokenPtr == afterSubexprPtr) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "too few arguments for math function", -1); + code = TCL_ERROR; goto done; } - - /* - * Check for a ',' between arguments or a ')' ending the - * argument list. - */ - - if (i == (mathFuncPtr->numArgs-1)) { - if (infoPtr->token == CLOSE_PAREN) { - break; /* exit the argument parsing loop */ - } else if (infoPtr->token == COMMA) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "too many arguments for math function", -1); - result = TCL_ERROR; - goto done; - } else { - goto syntaxError; - } - } - if (infoPtr->token != COMMA) { - if (infoPtr->token == CLOSE_PAREN) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "too few arguments for math function", -1); - result = TCL_ERROR; - goto done; - } else { - goto syntaxError; - } - } - result = GetToken(interp, infoPtr, envPtr); /* skip over , */ - if (result != TCL_OK) { + infoPtr->exprIsComparison = 0; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { goto done; } + tokenPtr += (tokenPtr->numComponents + 1); maxDepth++; } - } - - if (infoPtr->token != CLOSE_PAREN) { - goto syntaxError; - } - result = GetToken(interp, infoPtr, envPtr); /* skip over ')' */ - if (result != TCL_OK) { + if (tokenPtr != afterSubexprPtr) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "too many arguments for math function", -1); + code = TCL_ERROR; + goto done; + } + } else if (tokenPtr != afterSubexprPtr) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "too many arguments for math function", -1); + code = TCL_ERROR; goto done; } /* * Compile the call on the math function. Note that the "objc" argument * count for non-builtin functions is incremented by 1 to include the - * the function name itself. + * function name itself. */ if (mathFuncPtr->builtinFuncIndex >= 0) { /* a builtin function */ - TclEmitInstUInt1(INST_CALL_BUILTIN_FUNC1, - mathFuncPtr->builtinFuncIndex, envPtr); + TclEmitInstInt1(INST_CALL_BUILTIN_FUNC1, + mathFuncPtr->builtinFuncIndex, envPtr); } else { - TclEmitInstUInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr); + TclEmitInstInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr); } - - /* - * A comparison is not the top-level operator in this expression. - */ + *endPtrPtr = afterSubexprPtr; done: - infoPtr->exprIsComparison = 0; envPtr->maxStackDepth = maxDepth; - return result; - - syntaxError: - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "syntax error in expression \"", infoPtr->originalExpr, - "\"", (char *) NULL); - return TCL_ERROR; + return code; } /* *---------------------------------------------------------------------- * - * GetToken -- + * LogSyntaxError -- * - * Lexical scanner used to compile expressions: parses a single - * operator or other syntactic element from an expression string. - * - * Results: - * TCL_OK is returned unless an error occurred. In that case a standard - * Tcl error is returned, using the interpreter's result to hold an - * error message. TCL_ERROR is returned if an integer overflow, or a - * floating-point overflow or underflow occurred while reading in a - * number. If the lexical analysis is successful, infoPtr->token refers - * to the next symbol in the expression string, and infoPtr->next is - * advanced past the token. Also, if the token is a integer, double, or - * string literal, then infoPtr->objIndex the index of an object - * holding the value in the code's object table; otherwise is NULL. - * - * Side effects: - * Object are added to envPtr to hold the values of scanned literal - * integers, doubles, or strings. - * - *---------------------------------------------------------------------- - */ - -static int -GetToken(interp, infoPtr, envPtr) - Tcl_Interp *interp; /* Interpreter to use for error - * reporting. */ - register ExprInfo *infoPtr; /* Describes the state of the - * compiling the expression, - * including the resulting token. */ - CompileEnv *envPtr; /* Holds objects that store literal - * values that are scanned. */ -{ - register char *src; /* Points to current source char. */ - register char c; /* The current char. */ - register int type; /* Current char's CHAR_TYPE type. */ - char *termPtr; /* Points to char terminating a literal. */ - char savedChar; /* Holds the character termporarily replaced - * by a null character during processing of - * literal tokens. */ - int objIndex; /* The object array index for an object - * holding a scanned literal. */ - long longValue; /* Value of a scanned integer literal. */ - double doubleValue; /* Value of a scanned double literal. */ - Tcl_Obj *objPtr; - - /* - * First initialize the scanner's "result" fields to default values. - */ - - infoPtr->token = UNKNOWN; - infoPtr->objIndex = -1; - infoPtr->funcName = NULL; - - /* - * Scan over leading white space at the start of a token. Note that a - * backslash-newline is treated as a space. - */ - - src = infoPtr->next; - c = *src; - type = CHAR_TYPE(src, infoPtr->lastChar); - while ((type & (TCL_SPACE | TCL_BACKSLASH)) || (c == '\n')) { - if (type == TCL_BACKSLASH) { - if (src[1] == '\n') { - src += 2; - } else { - break; /* no longer white space */ - } - } else { - src++; - } - c = *src; - type = CHAR_TYPE(src, infoPtr->lastChar); - } - if (src == infoPtr->lastChar) { - infoPtr->token = END; - infoPtr->next = src; - return TCL_OK; - } - - /* - * Try to parse the token first as an integer or floating-point - * number. Don't check for a number if the first character is "+" or - * "-". If we did, we might treat a binary operator as unary by mistake, - * which would eventually cause a syntax error. - */ - - if ((*src != '+') && (*src != '-')) { - int startsWithDigit = isdigit(UCHAR(*src)); - - if (startsWithDigit && TclLooksLikeInt(src)) { - errno = 0; - longValue = strtoul(src, &termPtr, 0); - if (errno == ERANGE) { - char *s = "integer value too large to represent"; - - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, - (char *) NULL); - return TCL_ERROR; - } - if (termPtr != src) { - /* - * src was the start of a valid integer. Find/create an - * object in envPtr's object array to contain the integer. - */ - - savedChar = *termPtr; - *termPtr = '\0'; - objIndex = TclObjIndexForString(src, termPtr - src, - /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr); - *termPtr = savedChar; /* restore the saved char */ - - objPtr = envPtr->objArrayPtr[objIndex]; - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = longValue; - objPtr->typePtr = &tclIntType; - - infoPtr->token = LITERAL; - infoPtr->objIndex = objIndex; - infoPtr->next = termPtr; - return TCL_OK; - } - } else if (startsWithDigit || (*src == '.') - || (*src == 'n') || (*src == 'N')) { - errno = 0; - doubleValue = strtod(src, &termPtr); - if (termPtr != src) { - if (errno != 0) { - TclExprFloatError(interp, doubleValue); - return TCL_ERROR; - } - - /* - * Find/create an object in the object array containing the - * double. - */ - - savedChar = *termPtr; - *termPtr = '\0'; - objIndex = TclObjIndexForString(src, termPtr - src, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - *termPtr = savedChar; /* restore the saved char */ - - objPtr = envPtr->objArrayPtr[objIndex]; - objPtr->internalRep.doubleValue = doubleValue; - objPtr->typePtr = &tclDoubleType; - - infoPtr->token = LITERAL; - infoPtr->objIndex = objIndex; - infoPtr->next = termPtr; - return TCL_OK; - } - } - } - - /* - * Not an integer or double literal. Check next for a string literal - * in braces. - */ - - if (*src == '{') { - int level = 0; /* The {} nesting level. */ - int hasBackslashNL = 0; /* Nonzero if '\newline' was found. */ - char *string = src; /* Set below to point just after the - * starting '{'. */ - char *last; /* Points just before terminating '}'. */ - int numChars; /* Number of chars in braced string. */ - char savedChar; /* Holds the character from string - * termporarily replaced by a null char - * during braced string processing. */ - int numRead; - - /* - * Check first for any backslash-newlines, since we must treat - * backslash-newlines specially (they must be replaced by spaces). - */ - - while (1) { - if (src == infoPtr->lastChar) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "missing close-brace", -1); - return TCL_ERROR; - } else if (CHAR_TYPE(src, infoPtr->lastChar) == TCL_NORMAL) { - src++; - continue; - } - c = *src++; - if (c == '{') { - level++; - } else if (c == '}') { - --level; - if (level == 0) { - last = (src - 2); /* i.e. just before terminating } */ - break; - } - } else if (c == '\\') { - if (*src == '\n') { - hasBackslashNL = 1; - } - (void) Tcl_Backslash(src-1, &numRead); - src += numRead - 1; - } - } - - /* - * Create a string object for the braced string. This will start at - * "string" and ends just after "last" (which points to the final - * character before the terminating '}'). If backslash-newlines were - * found, we copy characters one at a time into a heap-allocated - * buffer and do backslash-newline substitutions. - */ - - string++; - numChars = (last - string + 1); - savedChar = string[numChars]; - string[numChars] = '\0'; - if (hasBackslashNL && (numChars > 0)) { - char *buffer = ckalloc((unsigned) numChars + 1); - register char *dst = buffer; - register char *p = string; - while (p <= last) { - c = *dst++ = *p++; - if (c == '\\') { - if (*p == '\n') { - dst[-1] = Tcl_Backslash(p-1, &numRead); - p += numRead - 1; - } else { - (void) Tcl_Backslash(p-1, &numRead); - while (numRead > 1) { - *dst++ = *p++; - numRead--; - } - } - } - } - *dst = '\0'; - objIndex = TclObjIndexForString(buffer, dst - buffer, - /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr); - } else { - objIndex = TclObjIndexForString(string, numChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - } - string[numChars] = savedChar; /* restore the saved char */ - - infoPtr->token = LITERAL; - infoPtr->objIndex = objIndex; - infoPtr->next = src; - return TCL_OK; - } - - /* - * Not an literal value. - */ - - infoPtr->next = src+1; /* assume a 1 char token and advance over it */ - switch (*src) { - case '[': - infoPtr->token = OPEN_BRACKET; - return TCL_OK; - - case ']': - infoPtr->token = CLOSE_BRACKET; - return TCL_OK; - - case '(': - infoPtr->token = OPEN_PAREN; - return TCL_OK; - - case ')': - infoPtr->token = CLOSE_PAREN; - return TCL_OK; - - case '$': - infoPtr->token = DOLLAR; - return TCL_OK; - - case '"': - infoPtr->token = QUOTE; - return TCL_OK; - - case ',': - infoPtr->token = COMMA; - return TCL_OK; - - case '*': - infoPtr->token = MULT; - return TCL_OK; - - case '/': - infoPtr->token = DIVIDE; - return TCL_OK; - - case '%': - infoPtr->token = MOD; - return TCL_OK; - - case '+': - infoPtr->token = PLUS; - return TCL_OK; - - case '-': - infoPtr->token = MINUS; - return TCL_OK; - - case '?': - infoPtr->token = QUESTY; - return TCL_OK; - - case ':': - infoPtr->token = COLON; - return TCL_OK; - - case '<': - switch (src[1]) { - case '<': - infoPtr->next = src+2; - infoPtr->token = LEFT_SHIFT; - break; - case '=': - infoPtr->next = src+2; - infoPtr->token = LEQ; - break; - default: - infoPtr->token = LESS; - break; - } - return TCL_OK; - - case '>': - switch (src[1]) { - case '>': - infoPtr->next = src+2; - infoPtr->token = RIGHT_SHIFT; - break; - case '=': - infoPtr->next = src+2; - infoPtr->token = GEQ; - break; - default: - infoPtr->token = GREATER; - break; - } - return TCL_OK; - - case '=': - if (src[1] == '=') { - infoPtr->next = src+2; - infoPtr->token = EQUAL; - } else { - infoPtr->token = UNKNOWN; - } - return TCL_OK; - - case '!': - if (src[1] == '=') { - infoPtr->next = src+2; - infoPtr->token = NEQ; - } else { - infoPtr->token = NOT; - } - return TCL_OK; - - case '&': - if (src[1] == '&') { - infoPtr->next = src+2; - infoPtr->token = AND; - } else { - infoPtr->token = BIT_AND; - } - return TCL_OK; - - case '^': - infoPtr->token = BIT_XOR; - return TCL_OK; - - case '|': - if (src[1] == '|') { - infoPtr->next = src+2; - infoPtr->token = OR; - } else { - infoPtr->token = BIT_OR; - } - return TCL_OK; - - case '~': - infoPtr->token = BIT_NOT; - return TCL_OK; - - default: - if (isalpha(UCHAR(*src))) { - infoPtr->token = FUNC_NAME; - infoPtr->funcName = src; - while (isalnum(UCHAR(*src)) || (*src == '_')) { - src++; - } - infoPtr->next = src; - return TCL_OK; - } - infoPtr->next = src+1; - infoPtr->token = UNKNOWN; - return TCL_OK; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateMathFunc -- - * - * Creates a new math function for expressions in a given - * interpreter. + * This procedure is invoked after an error occurs when compiling an + * expression. It sets the interpreter result to an error message + * describing the error. * * Results: * None. * * Side effects: - * The function defined by "name" is created or redefined. If the - * function already exists then its definition is replaced; this - * includes the builtin functions. Redefining a builtin function forces - * all existing code to be invalidated since that code may be compiled - * using an instruction specific to the replaced function. In addition, - * redefioning a non-builtin function will force existing code to be - * invalidated if the number of arguments has changed. + * Sets the interpreter result to an error message describing the + * expression that was being compiled when the error occurred. * *---------------------------------------------------------------------- */ -void -Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) - Tcl_Interp *interp; /* Interpreter in which function is - * to be available. */ - char *name; /* Name of function (e.g. "sin"). */ - int numArgs; /* Nnumber of arguments required by - * function. */ - Tcl_ValueType *argTypes; /* Array of types acceptable for - * each argument. */ - Tcl_MathProc *proc; /* Procedure that implements the - * math function. */ - ClientData clientData; /* Additional value to pass to the - * function. */ +static void +LogSyntaxError(infoPtr) + ExprInfo *infoPtr; /* Describes the compilation state for the + * expression being compiled. */ { - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hPtr; - MathFunc *mathFuncPtr; - int new, i; + int numBytes = (infoPtr->lastChar - infoPtr->expr); + char buffer[100]; - hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new); - if (new) { - Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc))); - } - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - - if (!new) { - if (mathFuncPtr->builtinFuncIndex >= 0) { - /* - * We are redefining a builtin math function. Invalidate the - * interpreter's existing code by incrementing its - * compileEpoch member. This field is checked in Tcl_EvalObj - * and ObjInterpProc, and code whose compilation epoch doesn't - * match is recompiled. Newly compiled code will no longer - * treat the function as builtin. - */ - - iPtr->compileEpoch++; - } else { - /* - * A non-builtin function is being redefined. We must invalidate - * existing code if the number of arguments has changed. This - * is because existing code was compiled assuming that number. - */ - - if (numArgs != mathFuncPtr->numArgs) { - iPtr->compileEpoch++; - } - } - } - - mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */ - if (numArgs > MAX_MATH_ARGS) { - numArgs = MAX_MATH_ARGS; - } - mathFuncPtr->numArgs = numArgs; - for (i = 0; i < numArgs; i++) { - mathFuncPtr->argTypes[i] = argTypes[i]; - } - mathFuncPtr->proc = proc; - mathFuncPtr->clientData = clientData; + sprintf(buffer, "syntax error in expression \"%.*s\"", + ((numBytes > 60)? 60 : numBytes), infoPtr->expr); + Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp), + buffer, (char *) NULL); } |