Logo Search packages:      
Sourcecode: tcl8.5 version File versions  Download package

tclCompExpr.c

/*
 * tclCompExpr.c --
 *
 *    This file contains the code to parse and compile Tcl expressions
 *    and implementations of the Tcl commands corresponding to expression
 *    operators, such as the command ::tcl::mathop::+ .
 *
 * Contributions from Don Porter, NIST, 2006-2007. (not subject to US copyright)
 *
 * 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.90 2007/12/13 15:23:15 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"       /* CompileEnv */

/*
 * Expression parsing takes place in the routine ParseExpr().  It takes a
 * string as input, parses that string, and generates a representation of
 * the expression in the form of a tree of operators, a list of literals,
 * a list of function names, and an array of Tcl_Token's within a Tcl_Parse
 * struct.  The tree is composed of OpNodes.
 */

typedef struct OpNode {
    int left;                 /* "Pointer" to the left operand. */
    int right;                /* "Pointer" to the right operand. */
    union {
      int parent;       /* "Pointer" to the parent operand. */
      int prev;         /* "Pointer" joining incomplete tree stack */
    } p;
    unsigned char lexeme;     /* Code that identifies the operator. */
    unsigned char precedence; /* Precedence of the operator */
    unsigned char mark;       /* Mark used to control traversal. */
    unsigned char constant;   /* Flag marking constant subexpressions. */
} OpNode;

/*
 * The storage for the tree is dynamically allocated array of OpNodes.  The
 * array is grown as parsing needs dictate according to a scheme similar to
 * Tcl's string growth algorithm, so that the resizing costs are O(N) and so
 * that we use at least half the memory allocated as expressions get large.
 *
 * Each OpNode in the tree represents an operator in the expression, either
 * unary or binary.  When parsing is completed successfully, a binary operator
 * OpNode will have its left and right fields filled with "pointers" to its
 * left and right operands.  A unary operator OpNode will have its right field
 * filled with a pointer to its single operand.  When an operand is a
 * subexpression the "pointer" takes the form of the index -- a non-negative
 * integer -- into the OpNode storage array where the root of that
 * subexpression parse tree is found.  
 *
 * Non-operator elements of the expression do not get stored in the OpNode
 * tree.  They are stored in the other structures according to their type.
 * Literal values get appended to the literal list.  Elements that denote
 * forms of quoting or substitution known to the Tcl parser get stored as
 * Tcl_Tokens.  These non-operator elements of the expression are the
 * leaves of the completed parse tree.  When an operand of an OpNode is
 * one of these leaf elements, the following negative integer codes are used
 * to indicate which kind of elements it is.
 */

enum OperandTypes {
    OT_LITERAL = -3,    /* Operand is a literal in the literal list */
    OT_TOKENS = -2,     /* Operand is sequence of Tcl_Tokens */
    OT_EMPTY = -1 /* "Operand" is an empty string.  This is a
                   * special case used only to represent the
                   * EMPTY lexeme.  See below. */
};

/*
 * Readable macros to test whether a "pointer" value points to an operator.
 * They operate on the "non-negative integer -> operator; negative integer ->
 * a non-operator OperandType" distinction.
 */

#define IsOperator(l)   ((l) >= 0)
#define NotOperator(l)  ((l) < 0)

/*
 * Note that it is sufficient to store in the tree just the type of leaf
 * operand, without any explicit pointer to which leaf.  This is true because
 * the traversals of the completed tree we perform are known to visit
 * the leaves in the same order as the original parse.
 *
 * In a completed parse tree, those OpNodes that are themselves (roots of
 * subexpression trees that are) operands of some operator store in their
 * p.parent field a "pointer" to the OpNode of that operator.  The p.parent
 * field permits a traversal of the tree within a * non-recursive routine
 * (ConvertTreeToTokens() and CompileExprTree()).  This means that even
 * expression trees of great depth pose no risk of blowing the C stack.
 *
 * While the parse tree is being constructed, the same memory space is used
 * to hold the p.prev field which chains together a stack of incomplete
 * trees awaiting their right operands.
 *
 * The lexeme field is filled in with the lexeme of the operator that is
 * returned by the ParseLexeme() routine.  Only lexemes for unary and
 * binary operators get stored in an OpNode.  Other lexmes get different
 * treatement.
 *
 * The precedence field provides a place to store the precedence of the
 * operator, so it need not be looked up again and again.
 *
 * The mark field is use to control the traversal of the tree, so
 * that it can be done non-recursively.  The mark values are:
 */

enum Marks {
    MARK_LEFT,          /* Next step of traversal is to visit left subtree */
    MARK_RIGHT,         /* Next step of traversal is to visit right subtree */
    MARK_PARENT,  /* Next step of traversal is to return to parent */
};

/*
 * The constant field is a boolean flag marking which subexpressions are
 * completely known at compile time, and are eligible for computing then
 * rather than waiting until run time.
 */

/*
 * Each lexeme belongs to one of four categories, which determine
 * its place in the parse tree.  We use the two high bits of the
 * (unsigned char) value to store a NODE_TYPE code.
 */

#define NODE_TYPE 0xC0

/*
 * The four category values are LEAF, UNARY, and BINARY, explained below,
 * and "uncategorized", which is used either temporarily, until context
 * determines which of the other three categories is correct, or for
 * lexemes like INVALID, which aren't really lexemes at all, but indicators
 * of a parsing error.  Note that the codes must be distinct to distinguish
 * categories, but need not take the form of a bit array.
 */

#define BINARY          0x40  /* This lexeme is a binary operator.  An
                         * OpNode representing it should go into the
                         * parse tree, and two operands should be
                         * parsed for it in the expression.  */
#define UNARY           0x80  /* This lexeme is a unary operator.  An OpNode
                         * representing it should go into the parse
                         * tree, and one operand should be parsed for
                         * it in the expression. */
#define LEAF            0xC0  /* This lexeme is a leaf operand in the parse
                         * tree.  No OpNode will be placed in the tree
                         * for it.  Either a literal value will be
                         * appended to the list of literals in this
                         * expression, or appropriate Tcl_Tokens will
                         * be appended in a Tcl_Parse struct to 
                         * represent those leaves that require some
                         * form of substitution.
                         */

/* Uncategorized lexemes */

#define PLUS            1     /* Ambiguous.  Resolves to UNARY_PLUS or
                         * BINARY_PLUS according to context. */
#define MINUS           2     /* Ambiguous.  Resolves to UNARY_MINUS or
                         * BINARY_MINUS according to context. */
#define BAREWORD  3     /* Ambigous.  Resolves to BOOLEAN or to
                         * FUNCTION or a parse error according to
                         * context and value. */
#define INCOMPLETE      4     /* A parse error.  Used only when the single
                         * "=" is encountered.  */
#define INVALID         5     /* A parse error.  Used when any punctuation
                         * appears that's not a supported operator. */

/* Leaf lexemes */

#define NUMBER          ( LEAF | 1) /* For literal numbers */
#define SCRIPT          ( LEAF | 2) /* Script substitution; [foo] */
#define BOOLEAN         ( LEAF | BAREWORD)      /* For literal booleans */
#define BRACED          ( LEAF | 4) /* Braced string; {foo bar} */
#define VARIABLE  ( LEAF | 5) /* Variable substitution; $x */
#define QUOTED          ( LEAF | 6) /* Quoted string; "foo $bar [soom]" */
#define EMPTY           ( LEAF | 7) /* Used only for an empty argument
                               * list to a function.  Represents
                               * the empty string within parens in
                               * the expression: rand() */

/* Unary operator lexemes */

#define UNARY_PLUS      ( UNARY | PLUS)
#define UNARY_MINUS     ( UNARY | MINUS)
#define FUNCTION  ( UNARY | BAREWORD)     /* This is a bit of "creative
                               * interpretation" on the part of the
                               * parser.  A function call is parsed
                               * into the parse tree according to
                               * the perspective that the function
                               * name is a unary operator and its
                               * argument list, enclosed in parens,
                               * is its operand.  The additional
                               * requirements not implied generally
                               * by treatment as a unary operator --
                               * for example, the requirement that
                               * the operand be enclosed in parens --
                               * are hard coded in the relevant
                               * portions of ParseExpr().  We trade
                               * off the need to include such
                               * exceptional handling in the code
                               * against the need we would otherwise
                               * have for more lexeme categories. */
#define START           ( UNARY | 4)      /* This lexeme isn't parsed from the
                               * expression text at all.  It
                               * represents the start of the
                               * expression and sits at the root of
                               * the parse tree where it serves as
                               * the start/end point of traversals. */
#define OPEN_PAREN      ( UNARY | 5)      /* Another bit of creative
                               * interpretation, where we treat "("
                               * as a unary operator with the
                               * sub-expression between it and its
                               * matching ")" as its operand. See
                               * CLOSE_PAREN below. */
#define NOT       ( UNARY | 6)
#define BIT_NOT         ( UNARY | 7)

/* Binary operator lexemes */

#define BINARY_PLUS     ( BINARY |  PLUS)
#define BINARY_MINUS    ( BINARY |  MINUS)
#define COMMA           ( BINARY |  3)    /* The "," operator is a low precedence
                               * binary operator that separates the
                               * arguments in a function call.  The
                               * additional constraint that this
                               * operator can only legally appear
                               * at the right places within a
                               * function call argument list are
                               * hard coded within ParseExpr().  */
#define MULT            ( BINARY |  4)
#define DIVIDE          ( BINARY |  5)
#define MOD       ( BINARY |  6)
#define LESS            ( BINARY |  7)
#define GREATER         ( BINARY |  8)
#define BIT_AND         ( BINARY |  9)
#define BIT_XOR         ( BINARY | 10)
#define BIT_OR          ( BINARY | 11)
#define QUESTION  ( BINARY | 12)    /* These two lexemes make up the */
#define COLON           ( BINARY | 13)    /* ternary conditional operator,
                               * $x ? $y : $z .  We treat them as
                               * two binary operators to avoid
                               * another lexeme category, and
                               * code the additional constraints
                               * directly in ParseExpr().  For
                               * instance, the right operand of
                               * a "?" operator must be a ":"
                               * operator. */
#define LEFT_SHIFT      ( BINARY | 14)
#define RIGHT_SHIFT     ( BINARY | 15)
#define LEQ       ( BINARY | 16)
#define GEQ       ( BINARY | 17)
#define EQUAL           ( BINARY | 18)
#define NEQ       ( BINARY | 19)
#define AND       ( BINARY | 20)
#define OR        ( BINARY | 21)
#define STREQ           ( BINARY | 22)
#define STRNEQ          ( BINARY | 23)
#define EXPON           ( BINARY | 24)    /* Unlike the other binary operators,
                               * EXPON is right associative and this
                               * distinction is coded directly in
                               * ParseExpr(). */
#define IN_LIST         ( BINARY | 25)
#define NOT_IN_LIST     ( BINARY | 26)
#define CLOSE_PAREN     ( BINARY | 27)    /* By categorizing the CLOSE_PAREN
                               * lexeme as a BINARY operator, the
                               * normal parsing rules for binary
                               * operators assure that a close paren
                               * will not directly follow another
                               * operator, and the machinery already
                               * in place to connect operands to
                               * operators according to precedence
                               * performs most of the work of
                               * matching open and close parens for
                               * us.  In the end though, a close
                               * paren is not really a binary
                               * operator, and some special coding
                               * in ParseExpr() make sure we never
                               * put an actual CLOSE_PAREN node
                               * in the parse tree.   The
                               * sub-expression between parens
                               * becomes the single argument of
                               * the matching OPEN_PAREN unary
                               * operator. */
#define END       ( BINARY | 28)    /* This lexeme represents the end of
                               * the string being parsed.  Treating
                               * it as a binary operator follows the
                               * same logic as the CLOSE_PAREN lexeme
                               * and END pairs with START, in the
                               * same way that CLOSE_PAREN pairs with
                               * OPEN_PAREN. */
/*
 * When ParseExpr() builds the parse tree it must choose which operands to
 * connect to which operators.  This is done according to operator precedence.
 * The greater an operator's precedence the greater claim it has to link to
 * an available operand.  The Precedence enumeration lists the precedence
 * values used by Tcl expression operators, from lowest to highest claim.
 * Each precedence level is commented with the operators that hold that
 * precedence.
 */

enum Precedence {
    PREC_END = 1, /* END */
    PREC_START,         /* START */
    PREC_CLOSE_PAREN,   /* ")" */
    PREC_OPEN_PAREN,    /* "(" */
    PREC_COMMA,         /* "," */
    PREC_CONDITIONAL,   /* "?", ":" */
    PREC_OR,            /* "||" */
    PREC_AND,           /* "&&" */
    PREC_BIT_OR,  /* "|" */
    PREC_BIT_XOR, /* "^" */
    PREC_BIT_AND, /* "&" */
    PREC_EQUAL,         /* "==", "!=", "eq", "ne", "in", "ni" */
    PREC_COMPARE, /* "<", ">", "<=", ">=" */
    PREC_SHIFT,         /* "<<", ">>" */
    PREC_ADD,           /* "+", "-" */
    PREC_MULT,          /* "*", "/", "%" */
    PREC_EXPON,         /* "**" */
    PREC_UNARY          /* "+", "-", FUNCTION, "!", "~" */
};

/*
 * Here the same information contained in the comments above is stored
 * in inverted form, so that given a lexeme, one can quickly look up 
 * its precedence value.
 */

static const unsigned char prec[] = {
    /* Non-operator lexemes */
    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
    0,
    /* Binary operator lexemes */
    PREC_ADD,           /* BINARY_PLUS */
    PREC_ADD,           /* BINARY_MINUS */
    PREC_COMMA,         /* COMMA */
    PREC_MULT,          /* MULT */
    PREC_MULT,          /* DIVIDE */
    PREC_MULT,          /* MOD */
    PREC_COMPARE, /* LESS */
    PREC_COMPARE, /* GREATER */
    PREC_BIT_AND, /* BIT_AND */
    PREC_BIT_XOR, /* BIT_XOR */
    PREC_BIT_OR,  /* BIT_OR */
    PREC_CONDITIONAL,   /* QUESTION */
    PREC_CONDITIONAL,   /* COLON */
    PREC_SHIFT,         /* LEFT_SHIFT */
    PREC_SHIFT,         /* RIGHT_SHIFT */
    PREC_COMPARE, /* LEQ */
    PREC_COMPARE, /* GEQ */
    PREC_EQUAL,         /* EQUAL */
    PREC_EQUAL,         /* NEQ */
    PREC_AND,           /* AND */
    PREC_OR,            /* OR */
    PREC_EQUAL,         /* STREQ */
    PREC_EQUAL,         /* STRNEQ */
    PREC_EXPON,         /* EXPON */
    PREC_EQUAL,         /* IN_LIST */
    PREC_EQUAL,         /* NOT_IN_LIST */
    PREC_CLOSE_PAREN,   /* CLOSE_PAREN */
    PREC_END,           /* END */
    /* Expansion room for more binary operators */
    0,  0,  0,
    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
    0,  
    /* Unary operator lexemes */
    PREC_UNARY,         /* UNARY_PLUS */
    PREC_UNARY,         /* UNARY_MINUS */
    PREC_UNARY,         /* FUNCTION */
    PREC_START,         /* START */
    PREC_OPEN_PAREN,    /* OPEN_PAREN */
    PREC_UNARY,         /* NOT*/
    PREC_UNARY,         /* BIT_NOT*/
};

/*
 * A table mapping lexemes to bytecode instructions, used by CompileExprTree().
 */

static const unsigned char instruction[] = {
    /* Non-operator lexemes */
    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
    0,
    /* Binary operator lexemes */
    INST_ADD,           /* BINARY_PLUS */
    INST_SUB,           /* BINARY_MINUS */
    0,                  /* COMMA */
    INST_MULT,          /* MULT */
    INST_DIV,           /* DIVIDE */
    INST_MOD,           /* MOD */
    INST_LT,            /* LESS */
    INST_GT,            /* GREATER */
    INST_BITAND,  /* BIT_AND */
    INST_BITXOR,  /* BIT_XOR */
    INST_BITOR,         /* BIT_OR */
    0,                  /* QUESTION */
    0,                  /* COLON */
    INST_LSHIFT,  /* LEFT_SHIFT */
    INST_RSHIFT,  /* RIGHT_SHIFT */
    INST_LE,            /* LEQ */
    INST_GE,            /* GEQ */
    INST_EQ,            /* EQUAL */
    INST_NEQ,           /* NEQ */
    0,                  /* AND */
    0,                  /* OR */
    INST_STR_EQ,  /* STREQ */
    INST_STR_NEQ, /* STRNEQ */
    INST_EXPON,         /* EXPON */
    INST_LIST_IN, /* IN_LIST */
    INST_LIST_NOT_IN,   /* NOT_IN_LIST */
    0,                  /* CLOSE_PAREN */
    0,                  /* END */
    /* Expansion room for more binary operators */
    0,  0,  0,
    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
    0,  
    /* Unary operator lexemes */
    INST_UPLUS,         /* UNARY_PLUS */
    INST_UMINUS,  /* UNARY_MINUS */
    0,                  /* FUNCTION */
    0,                  /* START */
    0,                  /* OPEN_PAREN */
    INST_LNOT,          /* NOT*/
    INST_BITNOT,  /* BIT_NOT*/
};

/*
 * A table mapping a byte value to the corresponding lexeme for use by
 * ParseLexeme().
 */

static unsigned char Lexeme[] = {
      INVALID           /* NUL */,  INVALID           /* SOH */,
      INVALID           /* STX */,  INVALID           /* ETX */,
      INVALID           /* EOT */,  INVALID           /* ENQ */,
      INVALID           /* ACK */,  INVALID           /* BEL */,
      INVALID           /* BS */,   INVALID           /* HT */,
      INVALID           /* LF */,   INVALID           /* VT */,
      INVALID           /* FF */,   INVALID           /* CR */,
      INVALID           /* SO */,   INVALID           /* SI */,
      INVALID           /* DLE */,  INVALID           /* DC1 */,
      INVALID           /* DC2 */,  INVALID           /* DC3 */,
      INVALID           /* DC4 */,  INVALID           /* NAK */,
      INVALID           /* SYN */,  INVALID           /* ETB */,
      INVALID           /* CAN */,  INVALID           /* EM */,
      INVALID           /* SUB */,  INVALID           /* ESC */,
      INVALID           /* FS */,   INVALID           /* GS */,
      INVALID           /* RS */,   INVALID           /* US */,
      INVALID           /* SPACE */,      0           /* ! or != */,
      QUOTED            /* " */,    INVALID           /* # */,
      VARIABLE    /* $ */,    MOD         /* % */,
      0           /* & or && */,    INVALID           /* ' */,
      OPEN_PAREN  /* ( */,    CLOSE_PAREN /* ) */,
      0           /* * or ** */,    PLUS        /* + */,
      COMMA       /* , */,    MINUS       /* - */,
      0           /* . */,    DIVIDE            /* / */,
      0, 0, 0, 0, 0, 0, 0, 0, 0, 0,             /* 0-9 */
      COLON       /* : */,    INVALID           /* ; */,
      0           /* < or << or <= */,
      0           /* == or INVALID */,
      0           /* > or >> or >= */,
      QUESTION    /* ? */,    INVALID           /* @ */,
      0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,          /* A-M */
      0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,          /* N-Z */
      SCRIPT            /* [ */,    INVALID           /* \ */,
      INVALID           /* ] */,    BIT_XOR           /* ^ */,
      INVALID           /* _ */,    INVALID           /* ` */,
      0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,          /* a-m */
      0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,          /* n-z */
      BRACED            /* { */,    0           /* | or || */,
      INVALID           /* } */,    BIT_NOT           /* ~ */,
      INVALID           /* DEL */
};

/*
 * The JumpList struct is used to create a stack of data needed for the
 * TclEmitForwardJump() and TclFixupForwardJump() calls that are performed
 * when compiling the short-circuiting operators QUESTION/COLON, AND, and OR.
 * Keeping a stack permits the CompileExprTree() routine to be non-recursive.
 */

typedef struct JumpList {
    JumpFixup jump;           /* Pass this argument to matching calls of
                         * TclEmitForwardJump() and 
                         * TclFixupForwardJump(). */
    int depth;                /* Remember the currStackDepth of the
                         * CompileEnv here. */
    int offset;               /* Data used to compute jump lengths to pass
                         * to TclFixupForwardJump() */
    int convert;        /* Temporary storage used to compute whether
                         * numeric conversion will be needed following
                         * the operator we're compiling. */
    struct JumpList *next;    /* Point to next item on the stack */
} JumpList;

/*
 * Declarations for local functions to this file:
 */

static void       CompileExprTree(Tcl_Interp *interp, OpNode *nodes,
                      int index, Tcl_Obj *const **litObjvPtr,
                      Tcl_Obj *const *funcObjv, Tcl_Token *tokenPtr,
                      CompileEnv *envPtr, int optimize);
static void       ConvertTreeToTokens(const char *start, int numBytes,
                      OpNode *nodes, Tcl_Token *tokenPtr,
                      Tcl_Parse *parsePtr);
static int        ExecConstantExprTree(Tcl_Interp *interp, OpNode *nodes,
                      int index, Tcl_Obj * const **litObjvPtr);
static int        ParseExpr(Tcl_Interp *interp, const char *start,
                      int numBytes, OpNode **opTreePtr,
                      Tcl_Obj *litList, Tcl_Obj *funcList,
                      Tcl_Parse *parsePtr, int parseOnly);
static int        ParseLexeme(const char *start, int numBytes,
                      unsigned char *lexemePtr, Tcl_Obj **literalPtr);


/*
 *----------------------------------------------------------------------
 *
 * ParseExpr --
 *
 *    Given a string, the numBytes bytes starting at start, this function
 *    parses it as a Tcl expression and constructs a tree representing
 *    the structure of the expression.  The caller must pass in empty
 *    lists as the funcList and litList arguments.  The elements of the
 *    parsed expression are returned to the caller as that tree, a list of
 *    literal values, a list of function names, and in Tcl_Tokens
 *    added to a Tcl_Parse struct passed in by the caller.
 *
 * Results:
 *    If the string is successfully parsed as a valid Tcl expression, TCL_OK
 *    is returned, and data about the expression structure is written to
 *    the last four arguments.  If the string cannot be parsed as a valid
 *    Tcl expression, TCL_ERROR is returned, and if interp is non-NULL, an
 *    error message is written to interp.
 *
 * Side effects:
 *    Memory will be allocated.  If TCL_OK is returned, the caller must
 *    clean up the returned data structures.  The (OpNode *) value written
 *    to opTreePtr should be passed to ckfree() and the parsePtr argument
 *    should be passed to Tcl_FreeParse().  The elements appended to the
 *    litList and funcList will automatically be freed whenever the
 *    refcount on those lists indicates they can be freed.
 *
 *----------------------------------------------------------------------
 */

static int
ParseExpr(
    Tcl_Interp *interp,       /* Used for error reporting. */
    const char *start,        /* Start of source string to parse. */
    int numBytes,       /* Number of bytes in string. */
    OpNode **opTreePtr,       /* Points to space where a pointer to the
                         * allocated OpNode tree should go. */
    Tcl_Obj *litList,         /* List to append literals to. */
    Tcl_Obj *funcList,        /* List to append function names to. */
    Tcl_Parse *parsePtr,      /* Structure to fill with tokens representing
                         * those operands that require run time
                         * substitutions. */
    int parseOnly)            /* A boolean indicating whether the caller's
                         * aim is just a parse, or whether it will go
                         * on to compile the expression.  Different
                         * optimizations are appropriate for the
                         * two scenarios. */
{
    OpNode *nodes = NULL;     /* Pointer to the OpNode storage array where
                         * we build the parse tree. */
    int nodesAvailable = 64;  /* Initial size of the storage array.  This
                         * value establishes a minimum tree memory cost
                         * of only about 1 kibyte, and is large enough
                         * for most expressions to parse with no need
                         * for array growth and reallocation. */
    int nodesUsed = 0;        /* Number of OpNodes filled. */
    int scanned = 0;          /* Capture number of byte scanned by 
                         * parsing routines. */
    int lastParsed;           /* Stores info about what the lexeme parsed
                         * the previous pass through the parsing loop
                         * was.  If it was an operator, lastParsed is
                         * the index of the OpNode for that operator.
                         * If it was not an operator, lastParsed holds
                         * an OperandTypes value encoding what we
                         * need to know about it. */
    int incomplete;           /* Index of the most recent incomplete tree
                         * in the OpNode array.  Heads a stack of
                         * incomplete trees linked by p.prev. */
    int complete = OT_EMPTY;  /* "Index" of the complete tree (that is, a
                         * complete subexpression) determined at the
                         * moment.   OT_EMPTY is a nonsense value
                         * used only to silence compiler warnings.
                         * During a parse, complete will always hold
                         * an index or an OperandTypes value pointing
                         * to an actual leaf at the time the complete
                         * tree is needed. */

    /* These variables control generation of the error message. */
    Tcl_Obj *msg = NULL;      /* The error message. */
    Tcl_Obj *post = NULL;     /* In a few cases, an additional postscript
                         * for the error message, supplying more
                         * information after the error msg and
                         * location have been reported. */
    const char *mark = "_@_"; /* In the portion of the complete error message
                         * where the error location is reported, this
                         * "mark" substring is inserted into the
                         * string being parsed to aid in pinpointing
                         * the location of the syntax error in the
                         * expression. */
    int insertMark = 0;       /* A boolean controlling whether the "mark"
                         * should be inserted. */
    const int limit = 25;     /* Portions of the error message are
                         * constructed out of substrings of the
                         * original expression.  In order to keep the
                         * error message readable, we impose this limit
                         * on the substring size we extract. */

    TclParseInit(interp, start, numBytes, parsePtr);

    nodes = (OpNode *) attemptckalloc(nodesAvailable * sizeof(OpNode));
    if (nodes == NULL) {
      TclNewLiteralStringObj(msg, "not enough memory to parse expression");
      goto error;
    }

    /* Initialize the parse tree with the special "START" node. */
    nodes->lexeme = START;
    nodes->precedence = prec[START];
    nodes->mark = MARK_RIGHT;
    nodes->constant = 1;
    incomplete = lastParsed = nodesUsed;
    nodesUsed++;

    /*
     * Main parsing loop parses one lexeme per iteration.  We exit the
     * loop only when there's a syntax error with a "goto error" which
     * takes us to the error handling code following the loop, or when
     * we've successfully completed the parse and we return to the caller.
     */

    while (1) {
      OpNode *nodePtr;  /* Points to the OpNode we may fill this
                         * pass through the loop. */
      unsigned char lexeme;   /* The lexeme we parse this iteration. */
      Tcl_Obj *literal; /* Filled by the ParseLexeme() call when
                         * a literal is parsed that has a Tcl_Obj
                         * rep worth preserving. */
      const char *lastStart = start - scanned;
                        /* Compute where the lexeme parsed the
                         * previous pass through the loop began.
                         * This is helpful for detecting invalid
                         * octals and providing more complete error
                         * messages. */

      /*
       * Each pass through this loop adds up to one more OpNode. Allocate
       * space for one if required.
       */

      if (nodesUsed >= nodesAvailable) {
          int size = nodesUsed * 2;
          OpNode *newPtr;

          do {
            newPtr = (OpNode *) attemptckrealloc((char *) nodes,
                  (unsigned int) size * sizeof(OpNode));
          } while ((newPtr == NULL)
                && ((size -= (size - nodesUsed) / 2) > nodesUsed));
          if (newPtr == NULL) {
            TclNewLiteralStringObj(msg,
                  "not enough memory to parse expression");
            goto error;
          }
          nodesAvailable = size;
          nodes = newPtr;
      }
      nodePtr = nodes + nodesUsed;

      /* Skip white space between lexemes. */
      scanned = TclParseAllWhiteSpace(start, numBytes);
      start += scanned;
      numBytes -= scanned;

      scanned = ParseLexeme(start, numBytes, &lexeme, &literal);

      /* Use context to categorize the lexemes that are ambiguous. */
      if ((NODE_TYPE & lexeme) == 0) {
          switch (lexeme) {
          case INVALID:
            msg = Tcl_ObjPrintf(
                  "invalid character \"%.*s\"", scanned, start);
            goto error;
          case INCOMPLETE:
            msg = Tcl_ObjPrintf(
                  "incomplete operator \"%.*s\"", scanned, start);
            goto error;
          case BAREWORD:

            /*
             * Most barewords in an expression are a syntax error.
             * The exceptions are that when a bareword is followed by
             * an open paren, it might be a function call, and when the
             * bareword is a legal literal boolean value, we accept that 
             * as well.
             */

            if (start[scanned+TclParseAllWhiteSpace(
                  start+scanned, numBytes-scanned)] == '(') {
                lexeme = FUNCTION;

                /*
                 * When we compile the expression we'll need the function
                 * name, and there's no place in the parse tree to store
                 * it, so we keep a separate list of all the function
                 * names we've parsed in the order we found them.
                 */

                Tcl_ListObjAppendElement(NULL, funcList, literal);
            } else {
                int b;
                if (Tcl_GetBooleanFromObj(NULL, literal, &b) == TCL_OK) {
                  lexeme = BOOLEAN;
                } else {
                  Tcl_DecrRefCount(literal);
                  msg = Tcl_ObjPrintf(
                        "invalid bareword \"%.*s%s\"",
                        (scanned < limit) ? scanned : limit - 3, start,
                        (scanned < limit) ? "" : "...");
                  post = Tcl_ObjPrintf(
                        "should be \"$%.*s%s\" or \"{%.*s%s}\"",
                        (scanned < limit) ? scanned : limit - 3,
                        start, (scanned < limit) ? "" : "...",
                        (scanned < limit) ? scanned : limit - 3,
                        start, (scanned < limit) ? "" : "...");
                  Tcl_AppendPrintfToObj(post,
                        " or \"%.*s%s(...)\" or ...",
                        (scanned < limit) ? scanned : limit - 3,
                        start, (scanned < limit) ? "" : "...");
                  if (NotOperator(lastParsed)) {
                      if ((lastStart[0] == '0')
                            && ((lastStart[1] == 'o')
                            || (lastStart[1] == 'O'))
                            && (lastStart[2] >= '0')
                            && (lastStart[2] <= '9')) {
                        const char *end = lastStart + 2;
                        Tcl_Obj* copy;
                        while (isdigit(*end)) {
                            end++;
                        }
                        copy = Tcl_NewStringObj(lastStart,
                              end - lastStart);
                        if (TclCheckBadOctal(NULL,
                              Tcl_GetString(copy))) {
                              TclNewLiteralStringObj(post,
                                    "(invalid octal number?)");
                        }
                        Tcl_DecrRefCount(copy);
                      }
                      scanned = 0;
                      insertMark = 1;
                      parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
                  }
                  goto error;
                }
            }
            break;
          case PLUS:
          case MINUS:
            if (IsOperator(lastParsed)) {

                /*
                 * A "+" or "-" coming just after another operator
                 * must be interpreted as a unary operator.
                 */

                lexeme |= UNARY;
            } else {
                lexeme |= BINARY;
            }
          }
      }     /* Uncategorized lexemes */

      /* Handle lexeme based on its category. */
      switch (NODE_TYPE & lexeme) {

      /*
       * Each LEAF results in either a literal getting appended to the
       * litList, or a sequence of Tcl_Tokens representing a Tcl word
       * getting appended to the parsePtr->tokens.  No OpNode is filled
       * for this lexeme.
       */

      case LEAF: {
          Tcl_Token *tokenPtr;
          const char *end = start;
          int wordIndex;
          int code = TCL_OK;

          /*
           * A leaf operand appearing just after something that's not an
           * operator is a syntax error.
           */

          if (NotOperator(lastParsed)) {
            msg = Tcl_ObjPrintf("missing operator at %s", mark);
            if (lastStart[0] == '0') {
                Tcl_Obj *copy = Tcl_NewStringObj(lastStart,
                      start + scanned - lastStart);
                if (TclCheckBadOctal(NULL, Tcl_GetString(copy))) {
                  TclNewLiteralStringObj(post,
                        "looks like invalid octal number");
                }
                Tcl_DecrRefCount(copy);
            }
            scanned = 0;
            insertMark = 1;
            parsePtr->errorType = TCL_PARSE_BAD_NUMBER;

            /* Free any literal to avoid a memleak. */
            if ((lexeme == NUMBER) || (lexeme == BOOLEAN)) {
                Tcl_DecrRefCount(literal);
            }
            goto error;
          }

          switch (lexeme) {
          case NUMBER:
          case BOOLEAN: {
            if (interp) {
                int new;
                /* LiteralEntry *lePtr; */
                Tcl_Obj *objPtr = TclCreateLiteral((Interp *)interp,
                      (char *)start, scanned,
                      /* hash */ (unsigned int) -1, &new,
                      /* nsPtr */ NULL, /* flags */ 0,
                      NULL /* &lePtr */);
                if (objPtr->typePtr != literal->typePtr) {
                  /*
                   * What we would like to do is this:
                   *
                   * lePtr->objPtr = literal;
                   * Tcl_IncrRefCount(literal);
                   * Tcl_DecrRefCount(objPtr);
                   *
                   * However, the design of the "global" and "local"
                   * LiteralTable does not permit the value of
                   * lePtr->objPtr to be changed.  So rather than
                   * replace lePtr->objPtr, we do surgery to transfer
                   * the intrep of literal into it.  Ugly stuff here
                   * that's generally unsafe, but ok here since we know
                   * the Tcl_ObjTypes literal might possibly have.
                   */
                  Tcl_Obj *toFree = literal;
                  literal = objPtr;
                  TclFreeIntRep(literal);
                  literal->typePtr = toFree->typePtr;
                  literal->internalRep = toFree->internalRep;
                  toFree->typePtr = NULL;
                  Tcl_DecrRefCount(toFree);
                }
            }

            Tcl_ListObjAppendElement(NULL, litList, literal);
            complete = lastParsed = OT_LITERAL;
            start += scanned;
            numBytes -= scanned;
            continue;
          }
          default:
            break;
          }

          /*
           * Remaining LEAF cases may involve filling Tcl_Tokens, so
           * make room for at least 2 more tokens.
           */

          if (parsePtr->numTokens+1 >= parsePtr->tokensAvailable) {
            TclExpandTokenArray(parsePtr);
          }
          wordIndex = parsePtr->numTokens;
          tokenPtr = parsePtr->tokenPtr + wordIndex;
          tokenPtr->type = TCL_TOKEN_WORD;
          tokenPtr->start = start;
          parsePtr->numTokens++;

          switch (lexeme) {
          case QUOTED:
            code = Tcl_ParseQuotedString(NULL, start, numBytes,
                  parsePtr, 1, &end);
            scanned = end - start;
            break;

          case BRACED:
            code = Tcl_ParseBraces(NULL, start, numBytes,
                      parsePtr, 1, &end);
            scanned = end - start;
            break;

          case VARIABLE:
            code = Tcl_ParseVarName(NULL, start, numBytes, parsePtr, 1);

            /*
             * Handle the quirk that Tcl_ParseVarName reports a successful
             * parse even when it gets only a "$" with no variable name.
             */

            tokenPtr = parsePtr->tokenPtr + wordIndex + 1;
            if (code == TCL_OK && tokenPtr->type != TCL_TOKEN_VARIABLE) {
                TclNewLiteralStringObj(msg, "invalid character \"$\"");
                goto error;
            }
            scanned = tokenPtr->size;
            break;

          case SCRIPT: {
            Tcl_Parse *nestedPtr =
                  (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse));

            tokenPtr = parsePtr->tokenPtr + parsePtr->numTokens;
            tokenPtr->type = TCL_TOKEN_COMMAND;
            tokenPtr->start = start;
            tokenPtr->numComponents = 0;

            end = start + numBytes;
            start++;
            while (1) {
                code = Tcl_ParseCommand(interp, start, (end - start), 1,
                      nestedPtr);
                if (code != TCL_OK) {
                  parsePtr->term = nestedPtr->term;
                  parsePtr->errorType = nestedPtr->errorType;
                  parsePtr->incomplete = nestedPtr->incomplete;
                  break;
                }
                start = (nestedPtr->commandStart + nestedPtr->commandSize);
                Tcl_FreeParse(nestedPtr);
                if ((nestedPtr->term < end) && (*(nestedPtr->term) == ']')
                      && !(nestedPtr->incomplete)) {
                  break;
                }

                if (start == end) {
                  TclNewLiteralStringObj(msg, "missing close-bracket");
                  parsePtr->term = tokenPtr->start;
                  parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
                  parsePtr->incomplete = 1;
                  code = TCL_ERROR;
                  break;
                }
            }
            TclStackFree(interp, nestedPtr);
            end = start;
            start = tokenPtr->start;
            scanned = end - start;
            tokenPtr->size = scanned;
            parsePtr->numTokens++;
            break;
          }
          }
          if (code != TCL_OK) {

            /*
             * Here we handle all the syntax errors generated by
             * the Tcl_Token generating parsing routines called in the
             * switch just above.  If the value of parsePtr->incomplete
             * is 1, then the error was an unbalanced '[', '(', '{',
             * or '"' and parsePtr->term is pointing to that unbalanced
             * character.  If the value of parsePtr->incomplete is 0,
             * then the error is one of lacking whitespace following a
             * quoted word, for example: expr {[an error {foo}bar]},
             * and parsePtr->term points to where the whitespace is
             * missing.  We reset our values of start and scanned so that
             * when our error message is constructed, the location of
             * the syntax error is sure to appear in it, even if the
             * quoted expression is truncated.
             */

            start = parsePtr->term;
            scanned = parsePtr->incomplete;
            goto error;
          }

          tokenPtr = parsePtr->tokenPtr + wordIndex;
          tokenPtr->size = scanned;
          tokenPtr->numComponents = parsePtr->numTokens - wordIndex - 1;
          if (!parseOnly && ((lexeme == QUOTED) || (lexeme == BRACED))) {

            /*
             * When this expression is destined to be compiled, and a
             * braced or quoted word within an expression is known at
             * compile time (no runtime substitutions in it), we can
             * store it as a literal rather than in its tokenized form.
             * This is an advantage since the compiled bytecode is going
             * to need the argument in Tcl_Obj form eventually, so it's
             * just as well to get there now.  Another advantage is that
             * with this conversion, larger constant expressions might
             * be grown and optimized.
             *
             * On the contrary, if the end goal of this parse is to
             * fill a Tcl_Parse for a caller of Tcl_ParseExpr(), then it's
             * wasteful to convert to a literal only to convert back again
             * later.
             */

            literal = Tcl_NewObj();
            if (TclWordKnownAtCompileTime(tokenPtr, literal)) {
                Tcl_ListObjAppendElement(NULL, litList, literal);
                complete = lastParsed = OT_LITERAL;
                parsePtr->numTokens = wordIndex;
                break;
            }
            Tcl_DecrRefCount(literal);
          }
          complete = lastParsed = OT_TOKENS;
          break;
      } /* case LEAF */

      case UNARY:

          /*
           * A unary operator appearing just after something that's not an
           * operator is a syntax error -- something trying to be the left
           * operand of an operator that doesn't take one.
           */

          if (NotOperator(lastParsed)) {
            msg = Tcl_ObjPrintf("missing operator at %s", mark);
            scanned = 0;
            insertMark = 1;
            goto error;
          }

          /* Create an OpNode for the unary operator */
          nodePtr->lexeme = lexeme;
          nodePtr->precedence = prec[lexeme];
          nodePtr->mark = MARK_RIGHT;

          /*
           * A FUNCTION cannot be a constant expression, because Tcl allows
           * functions to return variable results with the same arguments;
           * for example, rand().  Other unary operators can root a constant
           * expression, so long as the argument is a constant expression.
           */

          nodePtr->constant = (lexeme != FUNCTION);

          /*
           * This unary operator is a new incomplete tree, so push it
           * onto our stack of incomplete trees.  Also remember it as
           * the last lexeme we parsed.
           */

          nodePtr->p.prev = incomplete;
          incomplete = lastParsed = nodesUsed;
          nodesUsed++;
          break;

      case BINARY: {
          OpNode *incompletePtr;
          unsigned char precedence = prec[lexeme];

          /*
           * A binary operator appearing just after another operator is a
           * syntax error -- one of the two operators is missing an operand.
           */

          if (IsOperator(lastParsed)) {
            if ((lexeme == CLOSE_PAREN)
                  && (nodePtr[-1].lexeme == OPEN_PAREN)) {
                if (nodePtr[-2].lexeme == FUNCTION) {

                  /*
                   * Normally, "()" is a syntax error, but as a special
                   * case accept it as an argument list for a function.
                   * Treat this as a special LEAF lexeme, and restart
                   * the parsing loop with zero characters scanned.
                   * We'll parse the ")" again the next time through,
                   * but with the OT_EMPTY leaf as the subexpression
                   * between the parens.
                   */

                  scanned = 0;
                  complete = lastParsed = OT_EMPTY;
                  break;
                }
                msg = Tcl_ObjPrintf("empty subexpression at %s", mark);
                scanned = 0;
                insertMark = 1;
                goto error;
            }

            if (nodePtr[-1].precedence > precedence) {
                if (nodePtr[-1].lexeme == OPEN_PAREN) {
                  TclNewLiteralStringObj(msg, "unbalanced open paren");
                  parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
                } else if (nodePtr[-1].lexeme == COMMA) {
                  msg = Tcl_ObjPrintf(
                        "missing function argument at %s", mark);
                  scanned = 0;
                  insertMark = 1;
                } else if (nodePtr[-1].lexeme == START) {
                  TclNewLiteralStringObj(msg, "empty expression");
                }
            } else {
                if (lexeme == CLOSE_PAREN) {
                  TclNewLiteralStringObj(msg, "unbalanced close paren");
                } else if ((lexeme == COMMA)
                      && (nodePtr[-1].lexeme == OPEN_PAREN)
                      && (nodePtr[-2].lexeme == FUNCTION)) {
                  msg = Tcl_ObjPrintf(
                        "missing function argument at %s", mark);
                  scanned = 0;
                  insertMark = 1;
                }
            }
            if (msg == NULL) {
                msg = Tcl_ObjPrintf("missing operand at %s", mark);
                scanned = 0;
                insertMark = 1;
            }
            goto error;
          }

          /*
           * Here is where the tree comes together.  At this point, we
           * have a stack of incomplete trees corresponding to 
           * substrings that are incomplete expressions, followed by
           * a complete tree corresponding to a substring that is itself
           * a complete expression, followed by the binary operator we have
           * just parsed.  The incomplete trees can each be completed by
           * adding a right operand.
           *
           * To illustrate with an example, when we parse the expression
           * "1+2*3-4" and we reach this point having just parsed the "-"
           * operator, we have these incomplete trees: START, "1+", and
           * "2*".  Next we have the complete subexpression "3".  Last is
           * the "-" we've just parsed.
           *
           * The next step is to join our complete tree to an operator.
           * The choice is governed by the precedence and associativity
           * of the competing operators.  If we connect it as the right
           * operand of our most recent incomplete tree, we get a new
           * complete tree, and we can repeat the process.  The while
           * loop following repeats this until precedence indicates it
           * is time to join the complete tree as the left operand of
           * the just parsed binary operator.
           *
           * Continuing the example, the first pass through the loop
           * will join "3" to "2*"; the next pass will join "2*3" to
           * "1+".  Then we'll exit the loop and join "1+2*3" to "-".
           * When we return to parse another lexeme, our stack of
           * incomplete trees is START and "1+2*3-".
           */

          while (1) {
            incompletePtr = nodes + incomplete;

            if (incompletePtr->precedence < precedence) {
                break;
            }

            if (incompletePtr->precedence == precedence) {

                /* Right association rules for exponentiation. */
                if (lexeme == EXPON) {
                  break;
                }

                /*
                 * Special association rules for the conditional operators.
                 * The "?" and ":" operators have equal precedence, but
                 * must be linked up in sensible pairs.
                 */

                if ((incompletePtr->lexeme == QUESTION)
                      && (NotOperator(complete)
                      || (nodes[complete].lexeme != COLON))) {
                  break;
                }
                if ((incompletePtr->lexeme == COLON)
                      && (lexeme == QUESTION)) {
                  break;
                }
            }

            /* Some special syntax checks... */

            /* Parens must balance */
            if ((incompletePtr->lexeme == OPEN_PAREN)
                  && (lexeme != CLOSE_PAREN)) {
                TclNewLiteralStringObj(msg, "unbalanced open paren");
                parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
                goto error;
            }

            /* Right operand of "?" must be ":" */
            if ((incompletePtr->lexeme == QUESTION)
                  && (NotOperator(complete)
                  || (nodes[complete].lexeme != COLON))) {
                msg = Tcl_ObjPrintf(
                      "missing operator \":\" at %s", mark);
                scanned = 0;
                insertMark = 1;
                goto error;
            }

            /* Operator ":" may only be right operand of "?" */
            if (IsOperator(complete)
                  && (nodes[complete].lexeme == COLON)
                  && (incompletePtr->lexeme != QUESTION)) {
                TclNewLiteralStringObj(msg,
                      "unexpected operator \":\" "
                      "without preceding \"?\"");
                goto error;
            }

            /*
             * Attach complete tree as right operand of most recent
             * incomplete tree.
             */

            incompletePtr->right = complete;
            if (IsOperator(complete)) {
                nodes[complete].p.parent = incomplete;
                incompletePtr->constant = incompletePtr->constant
                      && nodes[complete].constant;
            } else {
                incompletePtr->constant = incompletePtr->constant
                      && (complete == OT_LITERAL);
            }

            /*
             * The QUESTION/COLON and FUNCTION/OPEN_PAREN combinations each
             * make up a single operator.  Force them to agree whether they
             * have a constant expression.
             */

            if ((incompletePtr->lexeme == QUESTION)
                  || (incompletePtr->lexeme == FUNCTION)) {
                nodes[complete].constant = incompletePtr->constant;
            }

            if (incompletePtr->lexeme == START) {

                /*
                 * Completing the START tree indicates we're done.
                 * Transfer the parse tree to the caller and return.
                 */

                *opTreePtr = nodes;
                return TCL_OK;
            }

            /*
             * With a right operand attached, last incomplete tree has
             * become the complete tree.  Pop it from the incomplete
             * tree stack.
             */

            complete = incomplete;
            incomplete = incompletePtr->p.prev;

            /* CLOSE_PAREN can only close one OPEN_PAREN. */
            if (incompletePtr->lexeme == OPEN_PAREN) {
                break;
            }
          }

          /* More syntax checks... */

          /* Parens must balance. */
          if (lexeme == CLOSE_PAREN) {
            if (incompletePtr->lexeme != OPEN_PAREN) {
                TclNewLiteralStringObj(msg, "unbalanced close paren");
                goto error;
            }
          }

          /* Commas must appear only in function argument lists. */
          if (lexeme == COMMA) {
            if  ((incompletePtr->lexeme != OPEN_PAREN)
                  || (incompletePtr[-1].lexeme != FUNCTION)) {
                TclNewLiteralStringObj(msg,
                      "unexpected \",\" outside function argument list");
                goto error;
            }
          }

          /* Operator ":" may only be right operand of "?" */
          if (IsOperator(complete) && (nodes[complete].lexeme == COLON)) {
            TclNewLiteralStringObj(msg,
                  "unexpected operator \":\" without preceding \"?\"");
            goto error;
          }

          /* Create no node for a CLOSE_PAREN lexeme. */
          if (lexeme == CLOSE_PAREN) {
            break;
          }

          /* Link complete tree as left operand of new node. */
          nodePtr->lexeme = lexeme;
          nodePtr->precedence = precedence;
          nodePtr->mark = MARK_LEFT;
          nodePtr->left = complete;

          /* 
           * The COMMA operator cannot be optimized, since the function
           * needs all of its arguments, and optimization would reduce
           * the number.  Other binary operators root constant expressions
           * when both arguments are constant expressions.
           */

          nodePtr->constant = (lexeme != COMMA);

          if (IsOperator(complete)) {
            nodes[complete].p.parent = nodesUsed;
            nodePtr->constant = nodePtr->constant
                  && nodes[complete].constant;
          } else {
            nodePtr->constant = nodePtr->constant
                  && (complete == OT_LITERAL);
          }

          /*
           * With a left operand attached and a right operand missing,
           * the just-parsed binary operator is root of a new incomplete
           * tree.  Push it onto the stack of incomplete trees.
           */

          nodePtr->p.prev = incomplete;
          incomplete = lastParsed = nodesUsed;
          nodesUsed++;
          break;
      }     /* case BINARY */
      }     /* lexeme handler */

      /* Advance past the just-parsed lexeme */
      start += scanned;
      numBytes -= scanned;
    } /* main parsing loop */

  error:

    /*
     * We only get here if there's been an error.
     * Any errors that didn't get a suitable parsePtr->errorType,
     * get recorded as syntax errors.
     */

    if (parsePtr->errorType == TCL_PARSE_SUCCESS) {
      parsePtr->errorType = TCL_PARSE_SYNTAX;
    }

    /* Free any partial parse tree we've built. */
    if (nodes != NULL) {
      ckfree((char*) nodes);
    }

    if (interp == NULL) {

      /* Nowhere to report an error message, so just free it */
      if (msg) {
          Tcl_DecrRefCount(msg);
      }
    } else {

      /*
       * Construct the complete error message.  Start with the simple
       * error message, pulled from the interp result if necessary...
       */

      if (msg == NULL) {
          msg = Tcl_GetObjResult(interp);
      }

      /*
       * Add a detailed quote from the bad expression, displaying and
       * sometimes marking the precise location of the syntax error.
       */

      Tcl_AppendPrintfToObj(msg, "\nin expression \"%s%.*s%.*s%s%s%.*s%s\"",
            ((start - limit) < parsePtr->string) ? "" : "...",
            ((start - limit) < parsePtr->string)
                  ? (start - parsePtr->string) : limit - 3,
            ((start - limit) < parsePtr->string)
                  ? parsePtr->string : start - limit + 3,
            (scanned < limit) ? scanned : limit - 3, start,
            (scanned < limit) ? "" : "...", insertMark ? mark : "",
            (start + scanned + limit > parsePtr->end)
                  ? parsePtr->end - (start + scanned) : limit-3,
            start + scanned,
            (start + scanned + limit > parsePtr->end) ? "" : "...");

      /* Next, append any postscript message. */
      if (post != NULL) {
          Tcl_AppendToObj(msg, ";\n", -1);
          Tcl_AppendObjToObj(msg, post);
          Tcl_DecrRefCount(post);
      }
      Tcl_SetObjResult(interp, msg);

      /* Finally, place context information in the errorInfo. */
      numBytes = parsePtr->end - parsePtr->string;
      Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
            "\n    (parsing expression \"%.*s%s\")",
            (numBytes < limit) ? numBytes : limit - 3,
            parsePtr->string, (numBytes < limit) ? "" : "..."));
    }

    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * ConvertTreeToTokens --
 *
 *    Given a string, the numBytes bytes starting at start, and an OpNode
 *    tree and Tcl_Token array created by passing that same string to
 *    ParseExpr(), this function writes into *parsePtr the sequence of
 *    Tcl_Tokens needed so to satisfy the historical interface provided
 *    by Tcl_ParseExpr().  Note that this routine exists only for the sake
 *    of the public Tcl_ParseExpr() routine.  It is not used by Tcl itself
 *    at all.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    The Tcl_Parse *parsePtr is filled with Tcl_Tokens representing the
 *    parsed expression.
 *
 *----------------------------------------------------------------------
 */

static void
ConvertTreeToTokens(
    const char *start,
    int numBytes,
    OpNode *nodes,
    Tcl_Token *tokenPtr,
    Tcl_Parse *parsePtr)
{
    int subExprTokenIdx = 0;
    OpNode *nodePtr = nodes;
    int next = nodePtr->right;

    while (1) {
      Tcl_Token *subExprTokenPtr;
      int scanned, parentIdx;
      unsigned char lexeme;

      /*
       * Advance the mark so the next exit from this node won't retrace
       * steps over ground already covered.
       */

      nodePtr->mark++;

      /* Handle next child node or leaf */
      switch (next) {
      case OT_EMPTY:

          /* No tokens and no characters for the OT_EMPTY leaf. */
          break;

      case OT_LITERAL:

          /* Skip any white space that comes before the literal */
          scanned = TclParseAllWhiteSpace(start, numBytes);
          start +=scanned;
          numBytes -= scanned;

          /* Reparse the literal to get pointers into source string */
          scanned = ParseLexeme(start, numBytes, &lexeme, NULL);

          if (parsePtr->numTokens + 1 >= parsePtr->tokensAvailable) {
            TclExpandTokenArray(parsePtr);
          }
          subExprTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens;
          subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR;
          subExprTokenPtr->start = start;
          subExprTokenPtr->size = scanned;
          subExprTokenPtr->numComponents = 1;
          subExprTokenPtr[1].type = TCL_TOKEN_TEXT;
          subExprTokenPtr[1].start = start;
          subExprTokenPtr[1].size = scanned;
          subExprTokenPtr[1].numComponents = 0;

          parsePtr->numTokens += 2;
          start +=scanned;
          numBytes -= scanned;
          break;

      case OT_TOKENS: {

          /*
           * tokenPtr points to a token sequence that came from parsing
           * a Tcl word.  A Tcl word is made up of a sequence of one or
           * more elements.  When the word is only a single element, it's
           * been the historical practice to replace the TCL_TOKEN_WORD
           * token directly with a TCL_TOKEN_SUB_EXPR token.  However,
           * when the word has multiple elements, a TCL_TOKEN_WORD token
           * is kept as a grouping device so that TCL_TOKEN_SUB_EXPR
           * always has only one element.  Wise or not, these are the
           * rules the Tcl expr parser has followed, and for the sake
           * of those few callers of Tcl_ParseExpr() we do not change
           * them now.  Internally, we can do better.
           */
      
          int toCopy = tokenPtr->numComponents + 1;

          if (tokenPtr->numComponents == tokenPtr[1].numComponents + 1) {

            /*
             * Single element word.  Copy tokens and convert the leading
             * token to TCL_TOKEN_SUB_EXPR.
             */

            while (parsePtr->numTokens + toCopy - 1
                  >= parsePtr->tokensAvailable) {
                TclExpandTokenArray(parsePtr);
            }
            subExprTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens;
            memcpy(subExprTokenPtr, tokenPtr,
                  (size_t) toCopy * sizeof(Tcl_Token));
            subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR;
            parsePtr->numTokens += toCopy;
          } else {

            /* 
             * Multiple element word.  Create a TCL_TOKEN_SUB_EXPR
             * token to lead, with fields initialized from the leading
             * token, then copy entire set of word tokens.
             */

            while (parsePtr->numTokens + toCopy
                  >= parsePtr->tokensAvailable) {
                TclExpandTokenArray(parsePtr);
            }
            subExprTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens;
            *subExprTokenPtr = *tokenPtr;
            subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR;
            subExprTokenPtr->numComponents++;
            subExprTokenPtr++;
            memcpy(subExprTokenPtr, tokenPtr,
                  (size_t) toCopy * sizeof(Tcl_Token));
            parsePtr->numTokens += toCopy + 1;
          }

          scanned = tokenPtr->start + tokenPtr->size - start;
          start +=scanned;
          numBytes -= scanned;
          tokenPtr += toCopy;
          break;
      }

      default:

          /* Advance to the child node, which is an operator. */
          nodePtr = nodes + next;

          /* Skip any white space that comes before the subexpression */
          scanned = TclParseAllWhiteSpace(start, numBytes);
          start +=scanned;
          numBytes -= scanned;

          /* Generate tokens for the operator / subexpression... */
          switch (nodePtr->lexeme) {
          case OPEN_PAREN:
          case COMMA:
          case COLON:

            /* 
             * Historical practice has been to have no Tcl_Tokens for
             * these operators.
             */

            break;

          default: {

            /*
             * Remember the index of the last subexpression we were
             * working on -- that of our parent.  We'll stack it later.
             */

            parentIdx = subExprTokenIdx;

            /*
             * Verify space for the two leading Tcl_Tokens representing
             * the subexpression rooted by this operator.  The first
             * Tcl_Token will be of type TCL_TOKEN_SUB_EXPR; the second
             * of type TCL_TOKEN_OPERATOR.
             */

            if (parsePtr->numTokens + 1 >= parsePtr->tokensAvailable) {
                TclExpandTokenArray(parsePtr);
            }
            subExprTokenIdx = parsePtr->numTokens;
            subExprTokenPtr = parsePtr->tokenPtr + subExprTokenIdx;
            parsePtr->numTokens += 2;
            subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR;
            subExprTokenPtr[1].type = TCL_TOKEN_OPERATOR;

            /*
             * Our current position scanning the string is the starting
             * point for this subexpression.
             */

            subExprTokenPtr->start = start;

            /*
             * Eventually, we know that the numComponents field of the
             * Tcl_Token of type TCL_TOKEN_OPERATOR will be 0.  This means
             * we can make other use of this field for now to track the
             * stack of subexpressions we have pending.
             */

            subExprTokenPtr[1].numComponents = parentIdx;
            break;
          }
          }
          break;
      }

      /* Determine which way to exit the node on this pass. */
    router:
      switch (nodePtr->mark) {
      case MARK_LEFT:
          next = nodePtr->left;
          break;

      case MARK_RIGHT:
          next = nodePtr->right;

          /* Skip any white space that comes before the operator */
          scanned = TclParseAllWhiteSpace(start, numBytes);
          start +=scanned;
          numBytes -= scanned;

          /*
           * Here we scan from the string the operator corresponding to
           * nodePtr->lexeme.
           */

          scanned = ParseLexeme(start, numBytes, &lexeme, NULL);

          switch(nodePtr->lexeme) {
          case OPEN_PAREN:
          case COMMA:
          case COLON:

            /* No tokens for these lexemes -> nothing to do. */
            break;

          default:

            /*
             * Record in the TCL_TOKEN_OPERATOR token the pointers into
             * the string marking where the operator is.
             */

            subExprTokenPtr = parsePtr->tokenPtr + subExprTokenIdx;
            subExprTokenPtr[1].start = start;
            subExprTokenPtr[1].size = scanned;
            break;
          }

          start +=scanned;
          numBytes -= scanned;
          break;

      case MARK_PARENT:
          switch (nodePtr->lexeme) {
          case START:

            /* When we get back to the START node, we're done. */
            return;

          case COMMA:
          case COLON:

            /* No tokens for these lexemes -> nothing to do. */
            break;

          case OPEN_PAREN:

            /* Skip past matching close paren. */
            scanned = TclParseAllWhiteSpace(start, numBytes);
            start +=scanned;
            numBytes -= scanned;
            scanned = ParseLexeme(start, numBytes, &lexeme, NULL);
            start +=scanned;
            numBytes -= scanned;
            break;

          default: {

            /*
             * Before we leave this node/operator/subexpression for the
             * last time, finish up its tokens....
             * 
             * Our current position scanning the string is where the
             * substring for the subexpression ends.
             */

            subExprTokenPtr = parsePtr->tokenPtr + subExprTokenIdx;
            subExprTokenPtr->size = start - subExprTokenPtr->start;

            /*
             * All the Tcl_Tokens allocated and filled belong to
             * this subexpresion.  The first token is the leading
             * TCL_TOKEN_SUB_EXPR token, and all the rest (one fewer)
             * are its components.
             */

            subExprTokenPtr->numComponents =
                  (parsePtr->numTokens - subExprTokenIdx) - 1;

            /*
             * Finally, as we return up the tree to our parent, pop the
             * parent subexpression off our subexpression stack, and
             * fill in the zero numComponents for the operator Tcl_Token.
             */

            parentIdx = subExprTokenPtr[1].numComponents;
            subExprTokenPtr[1].numComponents = 0;
            subExprTokenIdx = parentIdx;
            break;
          }
          }

          /* Since we're returning to parent, skip child handling code. */
          nodePtr = nodes + nodePtr->p.parent;
          goto router;
      }
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ParseExpr --
 *
 *    Given a string, the numBytes bytes starting at start, this function
 *    parses it as a Tcl expression and stores information about the
 *    structure of the expression in the Tcl_Parse struct indicated by the
 *    caller.
 *
 * Results:
 *    If the string is successfully parsed as a valid Tcl expression, TCL_OK
 *    is returned, and data about the expression structure is written to
 *    *parsePtr. If the string cannot be parsed as a valid Tcl expression,
 *    TCL_ERROR is returned, and if interp is non-NULL, an error message is
 *    written to interp.
 *
 * Side effects:
 *    If there is insufficient space in parsePtr to hold all the information
 *    about the expression, then additional space is malloc-ed. If the
 *    function returns TCL_OK then the caller must eventually invoke
 *    Tcl_FreeParse to release any additional space that was allocated.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ParseExpr(
    Tcl_Interp *interp,       /* Used for error reporting. */
    const char *start,        /* Start of source string to parse. */
    int numBytes,       /* Number of bytes in string. If < 0, the
                         * string consists of all bytes up to the
                         * first null character. */
    Tcl_Parse *parsePtr)      /* Structure to fill with information about
                         * the parsed expression; any previous
                         * information in the structure is ignored. */
{
    int code;
    OpNode *opTree = NULL;    /* Will point to the tree of operators */
    Tcl_Obj *litList = Tcl_NewObj();      /* List to hold the literals */
    Tcl_Obj *funcList = Tcl_NewObj();     /* List to hold the functon names*/
    Tcl_Parse *exprParsePtr =
          (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse));
                        /* Holds the Tcl_Tokens of substitutions */

    if (numBytes < 0) {
      numBytes = (start ? strlen(start) : 0);
    }

    code = ParseExpr(interp, start, numBytes, &opTree, litList,
          funcList, exprParsePtr, 1 /* parseOnly */);
    Tcl_DecrRefCount(funcList);
    Tcl_DecrRefCount(litList);

    TclParseInit(interp, start, numBytes, parsePtr);
    if (code == TCL_OK) {
      ConvertTreeToTokens(start, numBytes,
            opTree, exprParsePtr->tokenPtr, parsePtr);
    } else {
      parsePtr->term = exprParsePtr->term;
      parsePtr->errorType = exprParsePtr->errorType;
    }

    Tcl_FreeParse(exprParsePtr);
    TclStackFree(interp, exprParsePtr);
    ckfree((char *) opTree);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseLexeme --
 *
 *    Parse a single lexeme from the start of a string, scanning no more
 *    than numBytes bytes.
 *
 * Results:
 *    Returns the number of bytes scanned to produce the lexeme.
 *
 * Side effects:
 *    Code identifying lexeme parsed is writen to *lexemePtr.
 *
 *----------------------------------------------------------------------
 */

static int
ParseLexeme(
    const char *start,        /* Start of lexeme to parse. */
    int numBytes,       /* Number of bytes in string. */
    unsigned char *lexemePtr, /* Write code of parsed lexeme to this
                         * storage. */
    Tcl_Obj **literalPtr)     /* Write corresponding literal value to this
                           storage, if non-NULL. */
{
    const char *end;
    int scanned;
    Tcl_UniChar ch;
    Tcl_Obj *literal = NULL;
    unsigned char byte;

    if (numBytes == 0) {
      *lexemePtr = END;
      return 0;
    }
    byte = (unsigned char)(*start);
    if (byte < sizeof(Lexeme) && Lexeme[byte] != 0) {
      *lexemePtr = Lexeme[byte];
      return 1;
    }
    switch (byte) {
    case '*':
      if ((numBytes > 1) && (start[1] == '*')) {
          *lexemePtr = EXPON;
          return 2;
      }
      *lexemePtr = MULT;
      return 1;

    case '=':
      if ((numBytes > 1) && (start[1] == '=')) {
          *lexemePtr = EQUAL;
          return 2;
      }
      *lexemePtr = INCOMPLETE;
      return 1;

    case '!':
      if ((numBytes > 1) && (start[1] == '=')) {
          *lexemePtr = NEQ;
          return 2;
      }
      *lexemePtr = NOT;
      return 1;

    case '&':
      if ((numBytes > 1) && (start[1] == '&')) {
          *lexemePtr = AND;
          return 2;
      }
      *lexemePtr = BIT_AND;
      return 1;

    case '|':
      if ((numBytes > 1) && (start[1] == '|')) {
          *lexemePtr = OR;
          return 2;
      }
      *lexemePtr = BIT_OR;
      return 1;

    case '<':
      if (numBytes > 1) {
          switch (start[1]) {
          case '<':
            *lexemePtr = LEFT_SHIFT;
            return 2;
          case '=':
            *lexemePtr = LEQ;
            return 2;
          }
      }
      *lexemePtr = LESS;
      return 1;

    case '>':
      if (numBytes > 1) {
          switch (start[1]) {
          case '>':
            *lexemePtr = RIGHT_SHIFT;
            return 2;
          case '=':
            *lexemePtr = GEQ;
            return 2;
          }
      }
      *lexemePtr = GREATER;
      return 1;

    case 'i':
      if ((numBytes > 1) && (start[1] == 'n')
            && ((numBytes == 2) || !isalpha(UCHAR(start[2])))) {

          /*
           * Must make this check so we can tell the difference between
           * the "in" operator and the "int" function name and the
           * "infinity" numeric value.
           */

          *lexemePtr = IN_LIST;
          return 2;
      }
      break;

    case 'e':
      if ((numBytes > 1) && (start[1] == 'q')
            && ((numBytes == 2) || !isalpha(UCHAR(start[2])))) {
          *lexemePtr = STREQ;
          return 2;
      }
      break;

    case 'n':
      if ((numBytes > 1) && ((numBytes == 2) || !isalpha(UCHAR(start[2])))) {
          switch (start[1]) {
          case 'e':
            *lexemePtr = STRNEQ;
            return 2;
          case 'i':
            *lexemePtr = NOT_IN_LIST;
            return 2;
          }
      }
    }

    literal = Tcl_NewObj();
    if (TclParseNumber(NULL, literal, NULL, start, numBytes, &end,
          TCL_PARSE_NO_WHITESPACE) == TCL_OK) {
      TclInitStringRep(literal, start, end-start);
      *lexemePtr = NUMBER;
      if (literalPtr) {
          *literalPtr = literal;
      } else {
          Tcl_DecrRefCount(literal);
      }
      return (end-start);
    }

    if (Tcl_UtfCharComplete(start, numBytes)) {
      scanned = Tcl_UtfToUniChar(start, &ch);
    } else {
      char utfBytes[TCL_UTF_MAX];
      memcpy(utfBytes, start, (size_t) numBytes);
      utfBytes[numBytes] = '\0';
      scanned = Tcl_UtfToUniChar(utfBytes, &ch);
    }
    if (!isalpha(UCHAR(ch))) {
      *lexemePtr = INVALID;
      Tcl_DecrRefCount(literal);
      return scanned;
    }
    end = start;
    while (isalnum(UCHAR(ch)) || (UCHAR(ch) == '_')) {
      end += scanned;
      numBytes -= scanned;
      if (Tcl_UtfCharComplete(end, numBytes)) {
          scanned = Tcl_UtfToUniChar(end, &ch);
      } else {
          char utfBytes[TCL_UTF_MAX];
          memcpy(utfBytes, end, (size_t) numBytes);
          utfBytes[numBytes] = '\0';
          scanned = Tcl_UtfToUniChar(utfBytes, &ch);
      }
    }
    *lexemePtr = BAREWORD;
    if (literalPtr) {
      Tcl_SetStringObj(literal, start, (int) (end-start));
      *literalPtr = literal;
    } else {
      Tcl_DecrRefCount(literal);
    }
    return (end-start);
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileExpr --
 *
 *    This procedure compiles a string containing a Tcl expression into Tcl
 *    bytecodes. 
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    Adds instructions to envPtr to evaluate the expression at runtime.
 *
 *----------------------------------------------------------------------
 */

void
TclCompileExpr(
    Tcl_Interp *interp,       /* Used for error reporting. */
    const char *script,       /* The source script to compile. */
    int numBytes,       /* Number of bytes in script. */
    CompileEnv *envPtr)       /* Holds resulting instructions. */
{
    OpNode *opTree = NULL;    /* Will point to the tree of operators */
    Tcl_Obj *litList = Tcl_NewObj();      /* List to hold the literals */
    Tcl_Obj *funcList = Tcl_NewObj();     /* List to hold the functon names*/
    Tcl_Parse *parsePtr =
          (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse));
                        /* Holds the Tcl_Tokens of substitutions */

    int code = ParseExpr(interp, script, numBytes, &opTree, litList,
          funcList, parsePtr, 0 /* parseOnly */);

    if (code == TCL_OK) {

      /* Valid parse; compile the tree. */
      int objc;
      Tcl_Obj *const *litObjv;
      Tcl_Obj **funcObjv;

      /* TIP #280 : Track Lines within the expression */
      TclAdvanceLines(&envPtr->line, script,
            script + TclParseAllWhiteSpace(script, numBytes));

      TclListObjGetElements(NULL, litList, &objc, (Tcl_Obj ***)&litObjv);
      TclListObjGetElements(NULL, funcList, &objc, &funcObjv);
      CompileExprTree(interp, opTree, 0, &litObjv, funcObjv,
            parsePtr->tokenPtr, envPtr, 1 /* optimize */);
    } else {
      TclCompileSyntaxError(interp, envPtr);
    }

    Tcl_FreeParse(parsePtr);
    TclStackFree(interp, parsePtr);
    Tcl_DecrRefCount(funcList);
    Tcl_DecrRefCount(litList);
    ckfree((char *) opTree);
}

/*
 *----------------------------------------------------------------------
 *
 * ExecConstantExprTree --
 *    Compiles and executes bytecode for the subexpression tree at index
 *    in the nodes array.  This subexpression must be constant, made up
 *    of only constant operators (not functions) and literals.
 *
 * Results:
 *    A standard Tcl return code and result left in interp.
 *
 * Side effects:
 *    Consumes subtree of nodes rooted at index.  Advances the pointer
 *    *litObjvPtr.
 *
 *----------------------------------------------------------------------
 */

static int
ExecConstantExprTree(
    Tcl_Interp *interp,
    OpNode *nodes,
    int index,
    Tcl_Obj *const **litObjvPtr)
{
    CompileEnv *envPtr;
    ByteCode *byteCodePtr;
    int code;
    Tcl_Obj *byteCodeObj = Tcl_NewObj();

    /*
     * Note we are compiling an expression with literal arguments. This means
     * there can be no [info frame] calls when we execute the resulting
     * bytecode, so there's no need to tend to TIP 280 issues.
     */

    envPtr = (CompileEnv *) TclStackAlloc(interp, sizeof(CompileEnv));
    TclInitCompileEnv(interp, envPtr, NULL, 0, NULL, 0);
    CompileExprTree(interp, nodes, index, litObjvPtr, NULL, NULL, envPtr,
          0 /* optimize */);
    TclEmitOpcode(INST_DONE, envPtr);
    Tcl_IncrRefCount(byteCodeObj);
    TclInitByteCodeObj(byteCodeObj, envPtr);
    TclFreeCompileEnv(envPtr);
    TclStackFree(interp, envPtr);
    byteCodePtr = (ByteCode *) byteCodeObj->internalRep.otherValuePtr;
    code = TclExecuteByteCode(interp, byteCodePtr);
    Tcl_DecrRefCount(byteCodeObj);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * CompileExprTree --
 *    Compiles and writes to envPtr instructions for the subexpression
 *    tree at index in the nodes array.  (*litObjvPtr) must point to the
 *    proper location in a corresponding literals list.  Likewise, when
 *    non-NULL, funcObjv and tokenPtr must point into matching arrays of
 *    function names and Tcl_Token's derived from earlier call to
 *    ParseExpr().  When optimize is true, any constant subexpressions
 *    will be precomputed.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    Adds instructions to envPtr to evaluate the expression at runtime.
 *    Consumes subtree of nodes rooted at index.  Advances the pointer
 *    *litObjvPtr.
 *
 *----------------------------------------------------------------------
 */

static void
CompileExprTree(
    Tcl_Interp *interp,
    OpNode *nodes,
    int index,
    Tcl_Obj *const **litObjvPtr,
    Tcl_Obj *const *funcObjv,
    Tcl_Token *tokenPtr,
    CompileEnv *envPtr,
    int optimize)
{
    OpNode *nodePtr = nodes + index;
    OpNode *rootPtr = nodePtr;
    int numWords = 0;
    JumpList *jumpPtr = NULL;
    int convert = 1;

    while (1) {
      int next;
      JumpList *freePtr, *newJump;

      if (nodePtr->mark == MARK_LEFT) {
          next = nodePtr->left;

          switch (nodePtr->lexeme) {
          case QUESTION:
            newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList));
            newJump->next = jumpPtr;
            jumpPtr = newJump;
            newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList));
            newJump->next = jumpPtr;
            jumpPtr = newJump;
            jumpPtr->depth = envPtr->currStackDepth;
            convert = 1;
            break;
          case AND:
          case OR:
            newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList));
            newJump->next = jumpPtr;
            jumpPtr = newJump;
            newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList));
            newJump->next = jumpPtr;
            jumpPtr = newJump;
            newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList));
            newJump->next = jumpPtr;
            jumpPtr = newJump;
            jumpPtr->depth = envPtr->currStackDepth;
            break;
          }
      } else if (nodePtr->mark == MARK_RIGHT) {
          next = nodePtr->right;

          switch (nodePtr->lexeme) {
          case FUNCTION: {
            Tcl_DString cmdName;
            const char *p;
            int length;

            Tcl_DStringInit(&cmdName);
            Tcl_DStringAppend(&cmdName, "tcl::mathfunc::", -1);
            p = TclGetStringFromObj(*funcObjv, &length);
            funcObjv++;
            Tcl_DStringAppend(&cmdName, p, length);
            TclEmitPush(TclRegisterNewNSLiteral(envPtr,
                  Tcl_DStringValue(&cmdName),
                  Tcl_DStringLength(&cmdName)), envPtr);
            Tcl_DStringFree(&cmdName);

            /*
             * Start a count of the number of words in this function
             * command invocation.  In case there's already a count
             * in progress (nested functions), save it in our unused
             * "left" field for restoring later.
             */

            nodePtr->left = numWords;
            numWords = 2;     /* Command plus one argument */
            break;
          }
          case QUESTION:
            TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &(jumpPtr->jump));
            break;
          case COLON:
            TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
                  &(jumpPtr->next->jump));
            envPtr->currStackDepth = jumpPtr->depth;
            jumpPtr->offset = (envPtr->codeNext - envPtr->codeStart);
            jumpPtr->convert = convert;
            convert = 1;
            break;
          case AND:
            TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &(jumpPtr->jump));
            break;
          case OR:
            TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &(jumpPtr->jump));
            break;
          }
      } else {
          switch (nodePtr->lexeme) {
          case START:
          case QUESTION:
            if (convert && (nodePtr == rootPtr)) {
                TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
            }
            break;
          case OPEN_PAREN:

            /* do nothing */
            break;
          case FUNCTION:

            /*
             * Use the numWords count we've kept to invoke the
             * function command with the correct number of arguments.
             */
            
            if (numWords < 255) {
                TclEmitInstInt1(INST_INVOKE_STK1, numWords, envPtr);
            } else {
                TclEmitInstInt4(INST_INVOKE_STK4, numWords, envPtr);
            }

            /* Restore any saved numWords value. */
            numWords = nodePtr->left;
            convert = 1;
            break;
          case COMMA:

            /* Each comma implies another function argument. */
            numWords++;
            break;
          case COLON:
            if (TclFixupForwardJump(envPtr, &(jumpPtr->next->jump),
                  (envPtr->codeNext - envPtr->codeStart)
                  - jumpPtr->next->jump.codeOffset, 127)) {
                jumpPtr->offset += 3;
            }
            TclFixupForwardJump(envPtr, &(jumpPtr->jump),
                  jumpPtr->offset - jumpPtr->jump.codeOffset, 127);
            convert |= jumpPtr->convert;
            envPtr->currStackDepth = jumpPtr->depth + 1;
            freePtr = jumpPtr;
            jumpPtr = jumpPtr->next;
            TclStackFree(interp, freePtr);
            freePtr = jumpPtr;
            jumpPtr = jumpPtr->next;
            TclStackFree(interp, freePtr);
            break;
          case AND:
          case OR:
            TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND)
                  ?  TCL_FALSE_JUMP : TCL_TRUE_JUMP,
                  &(jumpPtr->next->jump));
            TclEmitPush(TclRegisterNewLiteral(envPtr,
                  (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr);
            TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
                  &(jumpPtr->next->next->jump));
            TclFixupForwardJumpToHere(envPtr, &(jumpPtr->next->jump), 127);
            if (TclFixupForwardJumpToHere(envPtr, &(jumpPtr->jump), 127)) {
                jumpPtr->next->next->jump.codeOffset += 3;
            }
            TclEmitPush(TclRegisterNewLiteral(envPtr,
                  (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr);
            TclFixupForwardJumpToHere(envPtr, &(jumpPtr->next->next->jump),
                  127);
            convert = 0;
            envPtr->currStackDepth = jumpPtr->depth + 1;
            freePtr = jumpPtr;
            jumpPtr = jumpPtr->next;
            TclStackFree(interp, freePtr);
            freePtr = jumpPtr;
            jumpPtr = jumpPtr->next;
            TclStackFree(interp, freePtr);
            freePtr = jumpPtr;
            jumpPtr = jumpPtr->next;
            TclStackFree(interp, freePtr);
            break;
          default:
            TclEmitOpcode(instruction[nodePtr->lexeme], envPtr);
            convert = 0;
            break;
          }
          if (nodePtr == rootPtr) {

            /* We're done */
            return;
          }
          nodePtr = nodes + nodePtr->p.parent;
          continue;
      }

      nodePtr->mark++;
      switch (next) {
      case OT_EMPTY:
          numWords = 1; /* No arguments, so just the command */
          break;
      case OT_LITERAL: {
          Tcl_Obj *const *litObjv = *litObjvPtr;
          Tcl_Obj *literal = *litObjv;
          int length;
          const char *bytes = TclGetStringFromObj(literal, &length);

          TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, length), envPtr);
          (*litObjvPtr)++;
          break;
      }
      case OT_TOKENS:
          TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents,
                envPtr);
          tokenPtr += tokenPtr->numComponents + 1;
          break;
      default:
          if (optimize && nodes[next].constant) {
            Tcl_InterpState save = Tcl_SaveInterpState(interp, TCL_OK);
            if (ExecConstantExprTree(interp, nodes, next, litObjvPtr)
                  == TCL_OK) {
                TclEmitPush(TclAddLiteralObj(envPtr,
                      Tcl_GetObjResult(interp), NULL), envPtr);
            } else {
                TclCompileSyntaxError(interp, envPtr);
            }
            Tcl_RestoreInterpState(interp, save);
            convert = 0;
          } else {
            nodePtr = nodes + next;
          }
      }
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclSingleOpCmd --
 *    Implements the commands: ~, !, <<, >>, %, !=, ne, in, ni
 *    in the ::tcl::mathop namespace.  These commands have no
 *    extension to arbitrary arguments; they accept only exactly one
 *    or exactly two arguments as suitable for the operator.
 *
 * Results:
 *    A standard Tcl return code and result left in interp.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

int
TclSingleOpCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
    unsigned char lexeme;
    OpNode nodes[2];
    Tcl_Obj *const *litObjv = objv + 1;

    if (objc != 1+occdPtr->i.numArgs) {
      Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected);
      return TCL_ERROR;
    }

    ParseLexeme(occdPtr->operator, strlen(occdPtr->operator), &lexeme, NULL);
    nodes[0].lexeme = START;
    nodes[0].mark = MARK_RIGHT;
    nodes[0].right = 1;
    nodes[1].lexeme = lexeme;
    if (objc == 2) {
      nodes[1].mark = MARK_RIGHT;
    } else {
      nodes[1].mark = MARK_LEFT;
      nodes[1].left = OT_LITERAL;
    }
    nodes[1].right = OT_LITERAL;
    nodes[1].p.parent = 0;

    return ExecConstantExprTree(interp, nodes, 0, &litObjv);
}

/*
 *----------------------------------------------------------------------
 *
 * TclSortingOpCmd --
 *    Implements the commands: <, <=, >, >=, ==, eq 
 *    in the ::tcl::mathop namespace.  These commands are defined for
 *    arbitrary number of arguments by computing the AND of the base
 *    operator applied to all neighbor argument pairs.
 *
 * Results:
 *    A standard Tcl return code and result left in interp.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

int
TclSortingOpCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    int code = TCL_OK;

    if (objc < 3) {
      Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1));
    } else {
      TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
      Tcl_Obj **litObjv = (Tcl_Obj **) TclStackAlloc(interp,
            2*(objc-2)*sizeof(Tcl_Obj *));
      OpNode *nodes = (OpNode *) TclStackAlloc(interp,
            2*(objc-2)*sizeof(OpNode));
      unsigned char lexeme;
      int i, lastAnd = 1;
      Tcl_Obj *const *litObjPtrPtr = litObjv;

      ParseLexeme(occdPtr->operator, strlen(occdPtr->operator),
            &lexeme, NULL);

      litObjv[0] = objv[1];
      nodes[0].lexeme = START;
      nodes[0].mark = MARK_RIGHT;
      for (i=2; i<objc-1; i++) {
          litObjv[2*(i-1)-1] = objv[i];
          nodes[2*(i-1)-1].lexeme = lexeme;
          nodes[2*(i-1)-1].mark = MARK_LEFT;
          nodes[2*(i-1)-1].left = OT_LITERAL;
          nodes[2*(i-1)-1].right = OT_LITERAL;

          litObjv[2*(i-1)] = objv[i];
          nodes[2*(i-1)].lexeme = AND;
          nodes[2*(i-1)].mark = MARK_LEFT;
          nodes[2*(i-1)].left = lastAnd;
          nodes[lastAnd].p.parent = 2*(i-1);

          nodes[2*(i-1)].right = 2*(i-1)+1;
          nodes[2*(i-1)+1].p.parent= 2*(i-1);

          lastAnd = 2*(i-1);
      }
      litObjv[2*(objc-2)-1] = objv[objc-1];

      nodes[2*(objc-2)-1].lexeme = lexeme;
      nodes[2*(objc-2)-1].mark = MARK_LEFT;
      nodes[2*(objc-2)-1].left = OT_LITERAL;
      nodes[2*(objc-2)-1].right = OT_LITERAL;

      nodes[0].right = lastAnd;
      nodes[lastAnd].p.parent = 0;

      code = ExecConstantExprTree(interp, nodes, 0, &litObjPtrPtr);

      TclStackFree(interp, nodes);
      TclStackFree(interp, litObjv);
    }
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclVariadicOpCmd --
 *    Implements the commands: +, *, &, |, ^, **
 *    in the ::tcl::mathop namespace.  These commands are defined for
 *    arbitrary number of arguments by repeatedly applying the base
 *    operator with suitable associative rules.  When fewer than two
 *    arguments are provided, suitable identity values are returned.
 *
 * Results:
 *    A standard Tcl return code and result left in interp.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

int
TclVariadicOpCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
    unsigned char lexeme;
    int code;

    if (objc < 2) {
      Tcl_SetObjResult(interp, Tcl_NewIntObj(occdPtr->i.identity));
      return TCL_OK;
    }

    ParseLexeme(occdPtr->operator, strlen(occdPtr->operator), &lexeme, NULL);
    lexeme |= BINARY;

    if (objc == 2) {
      Tcl_Obj *litObjv[2];
      OpNode nodes[2];
      int decrMe = 0;
      Tcl_Obj *const *litObjPtrPtr = litObjv;

      if (lexeme == EXPON) {
          litObjv[1] = Tcl_NewIntObj(occdPtr->i.identity);
          Tcl_IncrRefCount(litObjv[1]);
          decrMe = 1;
          litObjv[0] = objv[1];
          nodes[0].lexeme = START;
          nodes[0].mark = MARK_RIGHT;
          nodes[0].right = 1;
          nodes[1].lexeme = lexeme;
          nodes[1].mark = MARK_LEFT;
          nodes[1].left = OT_LITERAL;
          nodes[1].right = OT_LITERAL;
          nodes[1].p.parent = 0;
      } else {
          if (lexeme == DIVIDE) {
            litObjv[0] = Tcl_NewDoubleObj(1.0);
          } else {
            litObjv[0] = Tcl_NewIntObj(occdPtr->i.identity);
          }
          Tcl_IncrRefCount(litObjv[0]);
          litObjv[1] = objv[1];
          nodes[0].lexeme = START;
          nodes[0].mark = MARK_RIGHT;
          nodes[0].right = 1;
          nodes[1].lexeme = lexeme;
          nodes[1].mark = MARK_LEFT;
          nodes[1].left = OT_LITERAL;
          nodes[1].right = OT_LITERAL;
          nodes[1].p.parent = 0;
      }

      code = ExecConstantExprTree(interp, nodes, 0, &litObjPtrPtr);

      Tcl_DecrRefCount(litObjv[decrMe]);
      return code;
    } else {
      Tcl_Obj *const *litObjv = objv + 1;
      OpNode *nodes = (OpNode *) TclStackAlloc(interp,
            (objc-1)*sizeof(OpNode));
      int i, lastOp = OT_LITERAL;

      nodes[0].lexeme = START;
      nodes[0].mark = MARK_RIGHT;
      if (lexeme == EXPON) {
          for (i=objc-2; i>0; i-- ) {
            nodes[i].lexeme = lexeme;
            nodes[i].mark = MARK_LEFT;
            nodes[i].left = OT_LITERAL;
            nodes[i].right = lastOp;
            if (lastOp >= 0) {
                nodes[lastOp].p.parent = i;
            }
            lastOp = i;
          }
      } else {
          for (i=1; i<objc-1; i++ ) {
            nodes[i].lexeme = lexeme;
            nodes[i].mark = MARK_LEFT;
            nodes[i].left = lastOp;
            if (lastOp >= 0) {
                nodes[lastOp].p.parent = i;
            }
            nodes[i].right = OT_LITERAL;
            lastOp = i;
          }
      }
      nodes[0].right = lastOp;
      nodes[lastOp].p.parent = 0;

      code = ExecConstantExprTree(interp, nodes, 0, &litObjv);

      TclStackFree(interp, nodes);

      return code;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclNoIdentOpCmd --
 *    Implements the commands: -, /
 *    in the ::tcl::mathop namespace.  These commands are defined for
 *    arbitrary non-zero number of arguments by repeatedly applying
 *    the base operator with suitable associative rules.  When no
 *    arguments are provided, an error is raised.
 *
 * Results:
 *    A standard Tcl return code and result left in interp.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

int
TclNoIdentOpCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
    if (objc < 2) {
      Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected);
      return TCL_ERROR;
    }
    return TclVariadicOpCmd(clientData, interp, objc, objv);
}
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Generated by  Doxygen 1.6.0   Back to index