summaryrefslogtreecommitdiffstats
path: root/generic/tclCompExpr.c
diff options
context:
space:
mode:
authorrjohnson <rjohnson>1998-03-26 14:45:59 (GMT)
committerrjohnson <rjohnson>1998-03-26 14:45:59 (GMT)
commit2b5738da524e944cda39e24c0a87b745a43bd8c3 (patch)
tree6e8c9473978f6dab66c601e911721a7bd9d70b1b /generic/tclCompExpr.c
parentc6a259aeeca4814a97cf6694814c63e74e4e18fa (diff)
downloadtcl-2b5738da524e944cda39e24c0a87b745a43bd8c3.zip
tcl-2b5738da524e944cda39e24c0a87b745a43bd8c3.tar.gz
tcl-2b5738da524e944cda39e24c0a87b745a43bd8c3.tar.bz2
Initial revision
Diffstat (limited to 'generic/tclCompExpr.c')
-rw-r--r--generic/tclCompExpr.c2386
1 files changed, 2386 insertions, 0 deletions
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
new file mode 100644
index 0000000..6bae02b
--- /dev/null
+++ b/generic/tclCompExpr.c
@@ -0,0 +1,2386 @@
+/*
+ * 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.
+ *
+ * SCCS: @(#) tclCompExpr.c 1.34 97/11/03 14:29:18
+ */
+
+#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;
+}