URL
https://opencores.org/ocsvn/or1k/or1k/trunk
Subversion Repositories or1k
[/] [or1k/] [trunk/] [insight/] [tcl/] [generic/] [tclCompExpr.c] - Rev 1774
Go to most recent revision | Compare with Previous | Blame | View Log
/* * tclCompExpr.c -- * * This file contains the code to compile Tcl expressions. * * Copyright (c) 1996-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. * * RCS: @(#) $Id: tclCompExpr.c,v 1.1.1.1 2002-01-16 10:25:25 markom Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* * The stuff below is a bit of a hack so that this file can be used in * environments that include no UNIX, i.e. no errno: just arrange to use * the errno from tclExecute.c here. */ #ifndef TCL_GENERIC_ONLY #include "tclPort.h" #else #define NO_ERRNO_H #endif #ifdef NO_ERRNO_H extern int errno; /* Use errno from tclExecute.c. */ #define ERANGE 34 #endif /* * Boolean variable that controls whether expression compilation tracing * is enabled. */ #ifdef TCL_COMPILE_DEBUG static int traceCompileExpr = 0; #endif /* TCL_COMPILE_DEBUG */ /* * The ExprInfo structure describes the state of compiling an expression. * A pointer to an ExprInfo record is passed among the routines in * this module. */ 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. */ int hasOperators; /* Set 1 if the expr has operators; 0 if * expr is only a primary. If 1 after * compiling an expr, a tryCvtToNumeric * instruction is emitted to convert the * primary to a number if possible. */ int exprIsJustVarRef; /* Set 1 if the expr consists of just a * variable reference as in the expression * of "if $b then...". Otherwise 0. If 1 the * expr is compiled out-of-line in order to * implement expr's 2 level substitution * semantics properly. */ int exprIsComparison; /* Set 1 if the top-level operator in the * expr is a comparison. Otherwise 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. */ } ExprInfo; /* * Definitions of the different tokens that appear in expressions. The order * of these must match the corresponding entries in the operatorStrings * array below. */ #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) /* * Binary operators: */ #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) /* * Mapping from tokens to strings; used for debugging messages. These * entries must match the order and number of the token definitions above. */ #ifdef TCL_COMPILE_DEBUG static char *tokenStrings[] = { "LITERAL", "FUNCNAME", "[", "]", "(", ")", "$", "\"", ",", "END", "UNKNOWN", "*", "/", "%", "+", "-", "<<", ">>", "<", ">", "<=", ">=", "==", "!=", "&", "^", "|", "&&", "||", "?", ":", "!", "~" }; #endif /* TCL_COMPILE_DEBUG */ /* * 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, 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)); /* * Macro used to debug the execution of the recursive descent parser used * to compile expressions. */ #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); \ } #else #define HERE(production, level) #endif /* TCL_COMPILE_DEBUG */ /* *---------------------------------------------------------------------- * * TclCompileExpr -- * * This procedure compiles a string containing a Tcl expression into * Tcl bytecodes. This procedure is the top-level interface to the * the expression compilation module, and is used by such public * 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. * * envPtr->exprIsJustVarRef is set 1 if the expression 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 * expr 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. * *---------------------------------------------------------------------- */ int TclCompileExpr(interp, string, lastChar, flags, 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). */ 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 */ /* * Register the builtin math functions the first time an expression is * compiled. */ 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; } mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); mathFuncPtr->builtinFuncIndex = i; i++; } } info.token = UNKNOWN; info.objIndex = -1; info.funcName = NULL; info.next = string; info.originalExpr = string; info.lastChar = lastChar; 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. */ /* * Get the first token then compile an expression. */ result = GetToken(interp, &info, envPtr); if (result != TCL_OK) { goto done; } result = CompileCondExpr(interp, &info, flags, envPtr); if (result != TCL_OK) { goto done; } if (info.token != END) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "syntax error in expression \"", string, "\"", (char *) NULL); result = TCL_ERROR; goto done; } if (!info.hasOperators) { /* * Attempt to convert the primary's object to an int or double. * This is done in order to support Tcl's policy of interpreting * operands if at all possible as first integers, else * floating-point numbers. */ TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); } maxDepth = envPtr->maxStackDepth; done: envPtr->termOffset = (info.next - string); envPtr->maxStackDepth = maxDepth; envPtr->exprIsJustVarRef = info.exprIsJustVarRef; envPtr->exprIsComparison = info.exprIsComparison; return result; } /* *---------------------------------------------------------------------- * * CompileCondExpr -- * * 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. * * 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 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. */ { 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; } done: envPtr->maxStackDepth = maxDepth; return result; } /* *---------------------------------------------------------------------- * * CompileLorExpr -- * * This procedure compiles a Tcl logical or expression: * lorExpr ::= landExpr {'||' landExpr} * * 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 CompileLorExpr(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 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; } 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. */ 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; 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); } objIndex = TclObjIndexForString("1", 1, /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr); objPtr = envPtr->objArrayPtr[objIndex]; Tcl_InvalidateStringRep(objPtr); objPtr->internalRep.longValue = 1; objPtr->typePtr = &tclIntType; TclEmitPush(objIndex, envPtr); jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset); if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { panic("CompileLorExpr: bad jump distance %d\n", jumpDist); } } /* * 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; 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); } objIndex = TclObjIndexForString("1", 1, /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr); objPtr = envPtr->objArrayPtr[objIndex]; Tcl_InvalidateStringRep(objPtr); objPtr->internalRep.longValue = 1; objPtr->typePtr = &tclIntType; TclEmitPush(objIndex, envPtr); jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset); if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { panic("CompileLandExpr: bad jump distance %d\n", jumpDist); } } /* * 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 (jumpFixupArray.next == jumpFixupArray.end) { TclExpandJumpFixupArray(&jumpFixupArray); } fixupIndex = jumpFixupArray.next; jumpFixupArray.next++; TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &(jumpFixupArray.fixup[fixupIndex])); /* * Compile the subexpression. */ result = CompileBitOrExpr(interp, infoPtr, flags, envPtr); if (result != TCL_OK) { goto done; } maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); /* * 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. */ TclEmitOpcode(INST_LAND, 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; } /* *---------------------------------------------------------------------- * * 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; } 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; } /* *---------------------------------------------------------------------- * * CompileBitXorExpr -- * * This procedure compiles a Tcl bitwise exclusive or expression: * bitXorExpr ::= bitAndExpr {'^' bitAndExpr} * * 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 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. */ { 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. * *---------------------------------------------------------------------- */ 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; HERE("bitAndExpr", 6); result = CompileEqualityExpr(interp, infoPtr, flags, envPtr); if (result != 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. */ infoPtr->exprIsComparison = 0; } 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; } 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; /* * A comparison _is_ the top-level operator in this expression. */ infoPtr->exprIsComparison = 1; } 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; HERE("relationalExpr", 8); result = CompileShiftExpr(interp, infoPtr, flags, envPtr); if (result != TCL_OK) { goto done; } maxDepth = envPtr->maxStackDepth; 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); 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; } op = infoPtr->token; /* * A comparison _is_ the top-level operator in this expression. */ infoPtr->exprIsComparison = 1; } done: envPtr->maxStackDepth = maxDepth; return result; } /* *---------------------------------------------------------------------- * * CompileShiftExpr -- * * This procedure compiles a Tcl shift expression: * shiftExpr ::= addExpr {('<<' | '>>') addExpr} * * 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 CompileShiftExpr(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("shiftExpr", 9); result = CompileAddExpr(interp, infoPtr, flags, envPtr); if (result != TCL_OK) { goto done; } maxDepth = envPtr->maxStackDepth; 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; HERE("addExpr", 10); result = CompileMultiplyExpr(interp, infoPtr, flags, envPtr); if (result != 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; } 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. * *---------------------------------------------------------------------- */ 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; HERE("multiplyExpr", 11); result = CompileUnaryExpr(interp, infoPtr, flags, envPtr); if (result != 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; } 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. */ 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) { /* * Advance to the next token before returning. */ result = GetToken(interp, infoPtr, envPtr); if (result != TCL_OK) { goto done; } } done: envPtr->maxStackDepth = maxDepth; return result; syntaxError: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "syntax error in expression \"", infoPtr->originalExpr, "\"", (char *) NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * CompileMathFuncCall -- * * This procedure compiles a call on a math function in an expression: * mathFuncCall ::= funcName '(' [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 * contains an error message. * * envPtr->maxStackDepth is updated with the maximum number of stack * elements needed to execute the function. * * Side effects: * Adds instructions to envPtr to evaluate the math function at * runtime. * *---------------------------------------------------------------------- */ static int CompileMathFuncCall(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. */ { 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. */ Tcl_HashEntry *hPtr; char *p, *funcName; char savedChar; int result, 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. */ 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; 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; goto done; } mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); /* * 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); maxDepth = 1; } /* * Restore the saved character after the function name. */ *p = savedChar; /* * Compile the arguments for the function, if there are any. */ if (mathFuncPtr->numArgs > 0) { for (i = 0; ; i++) { infoPtr->exprIsComparison = 0; result = CompileCondExpr(interp, infoPtr, flags, envPtr); if (result != TCL_OK) { 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) { goto done; } maxDepth++; } } if (infoPtr->token != CLOSE_PAREN) { goto syntaxError; } result = GetToken(interp, infoPtr, envPtr); /* skip over ')' */ if (result != TCL_OK) { 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. */ if (mathFuncPtr->builtinFuncIndex >= 0) { /* a builtin function */ TclEmitInstUInt1(INST_CALL_BUILTIN_FUNC1, mathFuncPtr->builtinFuncIndex, envPtr); } else { TclEmitInstUInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr); } /* * A comparison is not the top-level operator in this expression. */ 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; } /* *---------------------------------------------------------------------- * * GetToken -- * * 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. * * 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. * *---------------------------------------------------------------------- */ 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. */ { Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; MathFunc *mathFuncPtr; int new, i; 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; }
Go to most recent revision | Compare with Previous | Blame | View Log