URL https://opencores.org/ocsvn/or1k/or1k/trunk
Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tcl/] [generic/] [tclCompExpr.c] - Blame information for rev 1767

Go to most recent revision | Details | Compare with Previous | 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;
}
Browse

Tools

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tcl/] [generic/] [tclCompExpr.c] - Blame information for rev 1767

Line No.	Rev	Author	Line
1	578	markom	`/*`
2			`* tclCompExpr.c --`
3			`*`
4			`* This file contains the code to compile Tcl expressions.`
5			`*`
6			`* Copyright (c) 1996-1997 Sun Microsystems, Inc.`
7			`*`
8			`* See the file "license.terms" for information on usage and redistribution`
9			`* of this file, and for a DISCLAIMER OF ALL WARRANTIES.`
10			`*`
11			`* RCS: @(#) $Id: tclCompExpr.c,v 1.1.1.1 2002-01-16 10:25:25 markom Exp $`
12			`*/`
13
14			`#include "tclInt.h"`
15			`#include "tclCompile.h"`
16
17			`/*`
18			`* The stuff below is a bit of a hack so that this file can be used in`
19			`* environments that include no UNIX, i.e. no errno: just arrange to use`
20			`* the errno from tclExecute.c here.`
21			`*/`
22
23			`#ifndef TCL_GENERIC_ONLY`
24			`#include "tclPort.h"`
25			`#else`
26			`#define NO_ERRNO_H`
27			`#endif`
28
29			`#ifdef NO_ERRNO_H`
30			`extern int errno; /* Use errno from tclExecute.c. */`
31			`#define ERANGE 34`
32			`#endif`
33
34			`/*`
35			`* Boolean variable that controls whether expression compilation tracing`
36			`* is enabled.`
37			`*/`
38
39			`#ifdef TCL_COMPILE_DEBUG`
40			`static int traceCompileExpr = 0;`