diff options
Diffstat (limited to 'generic/tclCompExpr.c')
| -rw-r--r-- | generic/tclCompExpr.c | 4415 |
1 files changed, 2418 insertions, 1997 deletions
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 6bae02b..94c1bd6 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -1,1328 +1,2107 @@ -/* +/* * tclCompExpr.c -- * - * This file contains the code to compile Tcl expressions. - * - * Copyright (c) 1996-1997 Sun Microsystems, Inc. + * 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::+ . * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * Contributions from Don Porter, NIST, 2006-2007. (not subject to US copyright) * - * SCCS: @(#) tclCompExpr.c 1.34 97/11/03 14:29:18 + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#include "tclCompile.h" +#include "tclCompile.h" /* CompileEnv */ /* - * The stuff below is a bit of a hack so that this file can be used in - * environments that include no UNIX, i.e. no errno: just arrange to use - * the errno from tclExecute.c here. + * 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. */ -#ifndef TCL_GENERIC_ONLY -#include "tclPort.h" -#else -#define NO_ERRNO_H -#endif +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; -#ifdef NO_ERRNO_H -extern int errno; /* Use errno from tclExecute.c. */ -#define ERANGE 34 -#endif +/* + * 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. */ +}; /* - * Boolean variable that controls whether expression compilation tracing - * is enabled. + * 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. */ -#ifdef TCL_COMPILE_DEBUG -static int traceCompileExpr = 0; -#endif /* TCL_COMPILE_DEBUG */ +#define IsOperator(l) ((l) >= 0) +#define NotOperator(l) ((l) < 0) /* - * The ExprInfo structure describes the state of compiling an expression. - * A pointer to an ExprInfo record is passed among the routines in - * this module. + * 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: */ -typedef struct ExprInfo { - int token; /* Type of the last token parsed in expr. - * See below for definitions. Corresponds - * to the characters just before next. */ - int objIndex; /* If token is a literal value, the index of - * an object holding the value in the code's - * object table; otherwise is NULL. */ - char *funcName; /* If the token is FUNC_NAME, points to the - * first character of the math function's - * name; otherwise is NULL. */ - char *next; /* Position of the next character to be - * scanned in the expression string. */ - char *originalExpr; /* The entire expression that was originally - * passed to Tcl_ExprString et al. */ - char *lastChar; /* Pointer to terminating null in - * originalExpr. */ - int hasOperators; /* Set 1 if the expr has operators; 0 if - * expr is only a primary. If 1 after - * compiling an expr, a tryCvtToNumeric - * instruction is emitted to convert the - * primary to a number if possible. */ - int exprIsJustVarRef; /* Set 1 if the expr consists of just a - * variable reference as in the expression - * of "if $b then...". Otherwise 0. If 1 the - * expr is compiled out-of-line in order to - * implement expr's 2 level substitution - * semantics properly. */ - int exprIsComparison; /* Set 1 if the top-level operator in the - * expr is a comparison. Otherwise 0. If 1, - * because the operands might be strings, - * the expr is compiled out-of-line in order - * to implement expr's 2 level substitution - * semantics properly. */ -} ExprInfo; +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 */ +}; /* - * Definitions of the different tokens that appear in expressions. The order - * of these must match the corresponding entries in the operatorStrings - * array below. + * 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. */ -#define LITERAL 0 -#define FUNC_NAME (LITERAL + 1) -#define OPEN_BRACKET (LITERAL + 2) -#define CLOSE_BRACKET (LITERAL + 3) -#define OPEN_PAREN (LITERAL + 4) -#define CLOSE_PAREN (LITERAL + 5) -#define DOLLAR (LITERAL + 6) -#define QUOTE (LITERAL + 7) -#define COMMA (LITERAL + 8) -#define END (LITERAL + 9) -#define UNKNOWN (LITERAL + 10) +/* + * 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 /* - * Binary operators: + * 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 MULT (UNKNOWN + 1) -#define DIVIDE (MULT + 1) -#define MOD (MULT + 2) -#define PLUS (MULT + 3) -#define MINUS (MULT + 4) -#define LEFT_SHIFT (MULT + 5) -#define RIGHT_SHIFT (MULT + 6) -#define LESS (MULT + 7) -#define GREATER (MULT + 8) -#define LEQ (MULT + 9) -#define GEQ (MULT + 10) -#define EQUAL (MULT + 11) -#define NEQ (MULT + 12) -#define BIT_AND (MULT + 13) -#define BIT_XOR (MULT + 14) -#define BIT_OR (MULT + 15) -#define AND (MULT + 16) -#define OR (MULT + 17) -#define QUESTY (MULT + 18) -#define COLON (MULT + 19) +#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. */ /* - * Unary operators. Unary minus and plus are represented by the (binary) - * tokens MINUS and PLUS. + * 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. */ -#define NOT (COLON + 1) -#define BIT_NOT (NOT + 1) +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, "!", "~" */ +}; /* - * Mapping from tokens to strings; used for debugging messages. These - * entries must match the order and number of the token definitions above. + * 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. */ -#ifdef TCL_COMPILE_DEBUG -static char *tokenStrings[] = { - "LITERAL", "FUNCNAME", - "[", "]", "(", ")", "$", "\"", ",", "END", "UNKNOWN", - "*", "/", "%", "+", "-", - "<<", ">>", "<", ">", "<=", ">=", "==", "!=", - "&", "^", "|", "&&", "||", "?", ":", - "!", "~" +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*/ }; -#endif /* TCL_COMPILE_DEBUG */ /* - * Declarations for local procedures to this file: + * A table mapping lexemes to bytecode instructions, used by CompileExprTree(). */ -static int CompileAddExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileBitAndExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileBitOrExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileBitXorExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileCondExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileEqualityExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileLandExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileLorExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileMathFuncCall _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileMultiplyExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompilePrimaryExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileRelationalExpr _ANSI_ARGS_(( - Tcl_Interp *interp, ExprInfo *infoPtr, - int flags, CompileEnv *envPtr)); -static int CompileShiftExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileUnaryExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int GetToken _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, CompileEnv *envPtr)); +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*/ +}; /* - * Macro used to debug the execution of the recursive descent parser used - * to compile expressions. + * A table mapping a byte value to the corresponding lexeme for use by + * ParseLexeme(). */ -#ifdef TCL_COMPILE_DEBUG -#define HERE(production, level) \ - if (traceCompileExpr) { \ - fprintf(stderr, "%*s%s: token=%s, next=\"%.20s\"\n", \ - (level), " ", (production), tokenStrings[infoPtr->token], \ - infoPtr->next); \ - } -#else -#define HERE(production, level) -#endif /* TCL_COMPILE_DEBUG */ +static const 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(). */ + 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); /* *---------------------------------------------------------------------- * - * TclCompileExpr -- - * - * This procedure compiles a string containing a Tcl expression into - * Tcl bytecodes. This procedure is the top-level interface to the - * the expression compilation module, and is used by such public - * procedures as Tcl_ExprString, Tcl_ExprStringObj, Tcl_ExprLong, - * Tcl_ExprDouble, Tcl_ExprBoolean, and Tcl_ExprBooleanObj. + * ParseExpr -- * - * Note that the topmost recursive-descent parsing routine used by - * TclCompileExpr to compile expressions is called "CompileCondExpr" - * and not, e.g., "CompileExpr". This is done to avoid an extra - * procedure call since such a procedure would only return the result - * of calling CompileCondExpr. Other recursive-descent procedures - * that need to parse expressions also call CompileCondExpr. + * 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: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed; this might - * be the offset of the ']' (if flags & TCL_BRACKET_TERM), or the - * offset of the '\0' at the end of the string. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * envPtr->exprIsJustVarRef is set 1 if the expression consisted of - * a single variable reference as in the expression of "if $b then...". - * Otherwise it is set 0. This is used to implement Tcl's two level - * expression substitution semantics properly. - * - * envPtr->exprIsComparison is set 1 if the top-level operator in the - * expr is a comparison. Otherwise it is set 0. If 1, because the - * operands might be strings, the expr is compiled out-of-line in order - * to implement expr's 2 level substitution semantics properly. + * 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: - * Adds instructions to envPtr to evaluate the expression at runtime. + * 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. * *---------------------------------------------------------------------- */ -int -TclCompileExpr(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +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. */ { - Interp *iPtr = (Interp *) interp; - ExprInfo info; - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int result; - -#ifdef TCL_COMPILE_DEBUG - if (traceCompileExpr) { - fprintf(stderr, "expr: string=\"%.30s\"\n", string); - } -#endif /* TCL_COMPILE_DEBUG */ + 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. */ /* - * Register the builtin math functions the first time an expression is - * compiled. + * These variables control generation of the error message. */ - if (!(iPtr->flags & EXPR_INITIALIZED)) { - BuiltinFunc *funcPtr; - Tcl_HashEntry *hPtr; - MathFunc *mathFuncPtr; - int i; - - iPtr->flags |= EXPR_INITIALIZED; - i = 0; - for (funcPtr = builtinFuncTable; funcPtr->name != NULL; funcPtr++) { - Tcl_CreateMathFunc(interp, funcPtr->name, - funcPtr->numArgs, funcPtr->argTypes, - (Tcl_MathProc *) NULL, (ClientData) 0); - - hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcPtr->name); - if (hPtr == NULL) { - panic("TclCompileExpr: Tcl_CreateMathFunc incorrectly registered '%s'", funcPtr->name); - return TCL_ERROR; - } - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - mathFuncPtr->builtinFuncIndex = i; - i++; - } + 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 *errCode = NULL; /* The detail word of the errorCode list, or + * NULL to indicate that no changes to the + * errorCode are to be done. */ + const char *subErrCode = NULL; + /* Extra information for use in generating the + * errorCode. */ + 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 = attemptckalloc(nodesAvailable * sizeof(OpNode)); + if (nodes == NULL) { + TclNewLiteralStringObj(msg, "not enough memory to parse expression"); + errCode = "NOMEM"; + goto error; } - info.token = UNKNOWN; - info.objIndex = -1; - info.funcName = NULL; - info.next = string; - info.originalExpr = string; - info.lastChar = lastChar; - info.hasOperators = 0; - info.exprIsJustVarRef = 1; /* will be set 0 if anything else is seen */ - info.exprIsComparison = 0; /* set 1 if topmost operator is <,==,etc. */ + /* + * 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++; /* - * Get the first token then compile an expression. + * 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. */ - result = GetToken(interp, &info, envPtr); - if (result != TCL_OK) { - goto done; - } - - result = CompileCondExpr(interp, &info, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - if (info.token != END) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "syntax error in expression \"", string, "\"", (char *) NULL); - result = TCL_ERROR; - goto done; - } - if (!info.hasOperators) { + 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. */ + /* - * Attempt to convert the primary's object to an int or double. - * This is done in order to support Tcl's policy of interpreting - * operands if at all possible as first integers, else - * floating-point numbers. + * Each pass through this loop adds up to one more OpNode. Allocate + * space for one if required. */ - - TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); - } - maxDepth = envPtr->maxStackDepth; - - done: - envPtr->termOffset = (info.next - string); - envPtr->maxStackDepth = maxDepth; - envPtr->exprIsJustVarRef = info.exprIsJustVarRef; - envPtr->exprIsComparison = info.exprIsComparison; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileCondExpr -- - * - * This procedure compiles a Tcl conditional expression: - * condExpr ::= lorExpr ['?' condExpr ':' condExpr] - * - * Note that this is the topmost recursive-descent parsing routine used - * by TclCompileExpr to compile expressions. It does not call an - * separate, higher-level "CompileExpr" procedure. This avoids an extra - * procedure call since such a procedure would only return the result - * of calling CompileCondExpr. Other recursive-descent procedures that - * need to parse expressions also call CompileCondExpr. - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ -static int -CompileCondExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - JumpFixup jumpAroundThenFixup, jumpAroundElseFixup; - /* Used to update or replace one-byte jumps - * around the then and else expressions when - * their target PCs are determined. */ - int elseCodeOffset, currCodeOffset, jumpDist, result; - - HERE("condExpr", 1); - result = CompileLorExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - - if (infoPtr->token == QUESTY) { - result = GetToken(interp, infoPtr, envPtr); /* skip over the '?' */ - if (result != TCL_OK) { - goto done; + if (nodesUsed >= nodesAvailable) { + int size = nodesUsed * 2; + OpNode *newPtr; + + do { + newPtr = attemptckrealloc(nodes, size * sizeof(OpNode)); + } while ((newPtr == NULL) + && ((size -= (size - nodesUsed) / 2) > nodesUsed)); + if (newPtr == NULL) { + TclNewLiteralStringObj(msg, + "not enough memory to parse expression"); + errCode = "NOMEM"; + goto error; + } + nodesAvailable = size; + nodes = newPtr; } + nodePtr = nodes + nodesUsed; /* - * Emit the jump around the "then" clause to the "else" condExpr if - * the test was false. We emit a one byte (relative) jump here, and - * replace it later with a four byte jump if the jump target is more - * than 127 bytes away. + * Skip white space between lexemes. */ - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpAroundThenFixup); + scanned = TclParseAllWhiteSpace(start, numBytes); + start += scanned; + numBytes -= scanned; + + scanned = ParseLexeme(start, numBytes, &lexeme, &literal); /* - * Compile the "then" expression. Note that if a subexpression - * is only a primary, we need to try to convert it to numeric. - * This is done in order to support Tcl's policy of interpreting - * operands if at all possible as first integers, else - * floating-point numbers. + * Use context to categorize the lexemes that are ambiguous. */ - infoPtr->hasOperators = 0; - infoPtr->exprIsJustVarRef = 0; - infoPtr->exprIsComparison = 0; - result = CompileCondExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - if (infoPtr->token != COLON) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "syntax error in expression \"", infoPtr->originalExpr, - "\"", (char *) NULL); - result = TCL_ERROR; - goto done; - } - if (!infoPtr->hasOperators) { - TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); - } - result = GetToken(interp, infoPtr, envPtr); /* skip over the ':' */ - if (result != TCL_OK) { - goto done; - } + if ((NODE_TYPE & lexeme) == 0) { + int b; + + switch (lexeme) { + case INVALID: + msg = Tcl_ObjPrintf("invalid character \"%.*s\"", + scanned, start); + errCode = "BADCHAR"; + goto error; + case INCOMPLETE: + msg = Tcl_ObjPrintf("incomplete operator \"%.*s\"", + scanned, start); + errCode = "PARTOP"; + goto error; + case BAREWORD: - /* - * Emit an unconditional jump around the "else" condExpr. - */ + /* + * 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. + */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpAroundElseFixup); + if (start[scanned+TclParseAllWhiteSpace( + start+scanned, numBytes-scanned)] == '(') { + lexeme = FUNCTION; - /* - * Compile the "else" expression. - */ + /* + * 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. + */ - infoPtr->hasOperators = 0; - elseCodeOffset = TclCurrCodeOffset(); - result = CompileCondExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - if (!infoPtr->hasOperators) { - TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); - } + Tcl_ListObjAppendElement(NULL, funcList, literal); + } else 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) ? "" : "..."); + errCode = "BAREWORD"; + if (start[0] == '0') { + const char *stop; + TclParseNumber(NULL, NULL, NULL, start, scanned, + &stop, TCL_PARSE_NO_WHITESPACE); + + if (isdigit(UCHAR(*stop)) || (stop == start + 1)) { + switch (start[1]) { + case 'b': + Tcl_AppendToObj(post, + " (invalid binary number?)", -1); + parsePtr->errorType = TCL_PARSE_BAD_NUMBER; + errCode = "BADNUMBER"; + subErrCode = "BINARY"; + break; + case 'o': + Tcl_AppendToObj(post, + " (invalid octal number?)", -1); + parsePtr->errorType = TCL_PARSE_BAD_NUMBER; + errCode = "BADNUMBER"; + subErrCode = "OCTAL"; + break; + default: + if (isdigit(UCHAR(start[1]))) { + Tcl_AppendToObj(post, + " (invalid octal number?)", -1); + parsePtr->errorType = TCL_PARSE_BAD_NUMBER; + errCode = "BADNUMBER"; + subErrCode = "OCTAL"; + } + break; + } + } + } + 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 */ /* - * Fix up the second jump: the unconditional jump around the "else" - * expression. If the distance is too great (> 127 bytes), replace - * it with a four byte instruction and move the instructions after - * the jump down. + * Handle lexeme based on its category. */ - currCodeOffset = TclCurrCodeOffset(); - jumpDist = (currCodeOffset - jumpAroundElseFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpAroundElseFixup, jumpDist, 127)) { + switch (NODE_TYPE & lexeme) { + case LEAF: { /* - * Update the else expression's starting code offset since it - * moved down 3 bytes too. + * 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. */ - - elseCodeOffset += 3; - } - - /* - * Now fix up the first branch: the jumpFalse after the test. If the - * distance is too great, replace it with a four byte instruction - * and update the code offsets for the commands in both the "then" - * and "else" expressions. - */ - jumpDist = (elseCodeOffset - jumpAroundThenFixup.codeOffset); - TclFixupForwardJump(envPtr, &jumpAroundThenFixup, jumpDist, 127); + Tcl_Token *tokenPtr; + const char *end = start; + int wordIndex; + int code = TCL_OK; - infoPtr->hasOperators = 1; + /* + * A leaf operand appearing just after something that's not an + * operator is a syntax error. + */ - /* - * A comparison is not the top-level operator in this expression. - */ + if (NotOperator(lastParsed)) { + msg = Tcl_ObjPrintf("missing operator at %s", mark); + errCode = "MISSING"; + scanned = 0; + insertMark = 1; - infoPtr->exprIsComparison = 0; - } + /* + * Free any literal to avoid a memleak. + */ - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileLorExpr -- - * - * This procedure compiles a Tcl logical or expression: - * lorExpr ::= landExpr {'||' landExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ + if ((lexeme == NUMBER) || (lexeme == BOOLEAN)) { + Tcl_DecrRefCount(literal); + } + goto error; + } -static int -CompileLorExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth; /* Maximum number of stack elements needed - * to execute the expression. */ - JumpFixupArray jumpFixupArray; - /* Used to fix up the forward "short - * circuit" jump after each or-ed - * subexpression to just after the last - * subexpression. */ - JumpFixup jumpTrueFixup, jumpFixup; - /* Used to emit the jumps in the code to - * convert the first operand to a 0 or 1. */ - int fixupIndex, jumpDist, currCodeOffset, objIndex, j, result; - Tcl_Obj *objPtr; - - HERE("lorExpr", 2); - result = CompileLandExpr(interp, infoPtr, flags, envPtr); - if ((result != TCL_OK) || (infoPtr->token != OR)) { - return result; /* envPtr->maxStackDepth is already set */ - } + switch (lexeme) { + case NUMBER: + case BOOLEAN: + /* + * TODO: Consider using a dict or hash to collapse all + * duplicate literals into a single representative value. + * (Like what is done with [split $s {}]). + * Pro: ~75% memory saving on expressions like + * {1+1+1+1+1+.....+1} (Convert "pointer + Tcl_Obj" cost + * to "pointer" cost only) + * Con: Cost of the dict store/retrieve on every literal in + * every expression when expressions like the above tend + * to be uncommon. + * The memory savings is temporary; Compiling to bytecode + * will collapse things as literals are registered + * anyway, so the savings applies only to the time + * between parsing and compiling. Possibly important due + * to high-water mark nature of memory allocation. + */ - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - maxDepth = envPtr->maxStackDepth; - TclInitJumpFixupArray(&jumpFixupArray); - while (infoPtr->token == OR) { - result = GetToken(interp, infoPtr, envPtr); /* skip over the '||' */ - if (result != TCL_OK) { - goto done; - } + Tcl_ListObjAppendElement(NULL, litList, literal); + complete = lastParsed = OT_LITERAL; + start += scanned; + numBytes -= scanned; + continue; + + default: + break; + } - if (jumpFixupArray.next == 0) { /* - * Just the first "lor" operand is on the stack. The following - * is slightly ugly: we need to convert that first "lor" operand - * to a "0" or "1" to get the correct result if it is nonzero. - * Eventually we'll use a new instruction for this. + * Remaining LEAF cases may involve filling Tcl_Tokens, so make + * room for at least 2 more tokens. */ - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpTrueFixup); - - objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; + TclGrowParseTokenArray(parsePtr, 2); + 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); - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = 0; - objPtr->typePtr = &tclIntType; - - TclEmitPush(objIndex, envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + /* + * 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 \"$\""); + errCode = "BADCHAR"; + goto error; + } + scanned = tokenPtr->size; + break; + + case SCRIPT: { + Tcl_Parse *nestedPtr = + 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[0] == ']') + && !nestedPtr->incomplete) { + break; + } - jumpDist = (TclCurrCodeOffset() - jumpTrueFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpTrueFixup, jumpDist, 127)) { - panic("CompileLorExpr: bad jump distance %d\n", jumpDist); + if (start == end) { + TclNewLiteralStringObj(msg, "missing close-bracket"); + parsePtr->term = tokenPtr->start; + parsePtr->errorType = TCL_PARSE_MISSING_BRACKET; + parsePtr->incomplete = 1; + code = TCL_ERROR; + errCode = "UNBALANCED"; + break; + } + } + TclStackFree(interp, nestedPtr); + end = start; + start = tokenPtr->start; + scanned = end - start; + tokenPtr->size = scanned; + parsePtr->numTokens++; + break; + } /* SCRIPT case */ } - objIndex = TclObjIndexForString("1", 1, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; + 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. + */ - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = 1; - objPtr->typePtr = &tclIntType; - - TclEmitPush(objIndex, envPtr); + start = parsePtr->term; + scanned = parsePtr->incomplete; + if (parsePtr->incomplete) { + errCode = "UNBALANCED"; + } + goto error; + } - jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { - panic("CompileLorExpr: bad jump distance %d\n", jumpDist); + 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 */ - /* - * Duplicate the value on top of the stack to prevent the jump from - * consuming it. - */ + case UNARY: - TclEmitOpcode(INST_DUP, envPtr); + /* + * 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. + */ - /* - * Emit the "short circuit" jump around the rest of the lorExp if - * the previous expression was true. We emit a one byte (relative) - * jump here, and replace it later with a four byte jump if the jump - * target is more than 127 bytes away. - */ + if (NotOperator(lastParsed)) { + msg = Tcl_ObjPrintf("missing operator at %s", mark); + scanned = 0; + insertMark = 1; + errCode = "MISSING"; + goto error; + } - if (jumpFixupArray.next == jumpFixupArray.end) { - TclExpandJumpFixupArray(&jumpFixupArray); - } - fixupIndex = jumpFixupArray.next; - jumpFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, - &(jumpFixupArray.fixup[fixupIndex])); - - /* - * Compile the subexpression. - */ + /* + * Create an OpNode for the unary operator. + */ - result = CompileLandExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + nodePtr->lexeme = lexeme; + nodePtr->precedence = prec[lexeme]; + nodePtr->mark = MARK_RIGHT; - /* - * Emit a "logical or" instruction. This does not try to "short- - * circuit" the evaluation of both operands of a Tcl "||" operator, - * but instead ensures that we either have a "1" or a "0" result. - */ + /* + * 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. + */ - TclEmitOpcode(INST_LOR, envPtr); - } + nodePtr->constant = (lexeme != FUNCTION); - /* - * Now that we know the target of the forward jumps, update the jumps - * with the correct distance. Also, if the distance is too great (> 127 - * bytes), replace the jump with a four byte instruction and move the - * instructions after the jump down. - */ - - for (j = jumpFixupArray.next; j > 0; j--) { - fixupIndex = (j - 1); /* process closest jump first */ - currCodeOffset = TclCurrCodeOffset(); - jumpDist = (currCodeOffset - jumpFixupArray.fixup[fixupIndex].codeOffset); - TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]), jumpDist, 127); - } + /* + * 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. + */ - /* - * We get here only if one or more ||'s appear as top-level operators. - */ + nodePtr->p.prev = incomplete; + incomplete = lastParsed = nodesUsed; + nodesUsed++; + break; - done: - infoPtr->exprIsComparison = 0; - TclFreeJumpFixupArray(&jumpFixupArray); - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileLandExpr -- - * - * This procedure compiles a Tcl logical and expression: - * landExpr ::= bitOrExpr {'&&' bitOrExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ + case BINARY: { + OpNode *incompletePtr; + unsigned char precedence = prec[lexeme]; -static int -CompileLandExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth; /* Maximum number of stack elements needed - * to execute the expression. */ - JumpFixupArray jumpFixupArray; - /* Used to fix up the forward "short - * circuit" jump after each and-ed - * subexpression to just after the last - * subexpression. */ - JumpFixup jumpTrueFixup, jumpFixup; - /* Used to emit the jumps in the code to - * convert the first operand to a 0 or 1. */ - int fixupIndex, jumpDist, currCodeOffset, objIndex, j, result; - Tcl_Obj *objPtr; - - HERE("landExpr", 3); - result = CompileBitOrExpr(interp, infoPtr, flags, envPtr); - if ((result != TCL_OK) || (infoPtr->token != AND)) { - return result; /* envPtr->maxStackDepth is already set */ - } + /* + * A binary operator appearing just after another operator is a + * syntax error -- one of the two operators is missing an operand. + */ - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - maxDepth = envPtr->maxStackDepth; - TclInitJumpFixupArray(&jumpFixupArray); - while (infoPtr->token == AND) { - result = GetToken(interp, infoPtr, envPtr); /* skip over the '&&' */ - if (result != TCL_OK) { - goto done; - } + if (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 + * will 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; + errCode = "EMPTY"; + goto error; + } + + if (nodePtr[-1].precedence > precedence) { + if (nodePtr[-1].lexeme == OPEN_PAREN) { + TclNewLiteralStringObj(msg, "unbalanced open paren"); + parsePtr->errorType = TCL_PARSE_MISSING_PAREN; + errCode = "UNBALANCED"; + } else if (nodePtr[-1].lexeme == COMMA) { + msg = Tcl_ObjPrintf( + "missing function argument at %s", mark); + scanned = 0; + insertMark = 1; + errCode = "MISSING"; + } else if (nodePtr[-1].lexeme == START) { + TclNewLiteralStringObj(msg, "empty expression"); + errCode = "EMPTY"; + } + } else if (lexeme == CLOSE_PAREN) { + TclNewLiteralStringObj(msg, "unbalanced close paren"); + errCode = "UNBALANCED"; + } 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; + errCode = "UNBALANCED"; + } + if (msg == NULL) { + msg = Tcl_ObjPrintf("missing operand at %s", mark); + scanned = 0; + insertMark = 1; + errCode = "MISSING"; + } + goto error; + } - if (jumpFixupArray.next == 0) { /* - * Just the first "land" operand is on the stack. The following - * is slightly ugly: we need to convert the first "land" operand - * to a "0" or "1" to get the correct result if it is - * nonzero. Eventually we'll use a new instruction. + * 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-". */ - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpTrueFixup); - - objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; + while (1) { + incompletePtr = nodes + incomplete; - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = 0; - objPtr->typePtr = &tclIntType; - - TclEmitPush(objIndex, envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + 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; + errCode = "UNBALANCED"; + 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; + errCode = "MISSING"; + 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 \"?\""); + errCode = "SURPRISE"; + 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. + */ - jumpDist = (TclCurrCodeOffset() - jumpTrueFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpTrueFixup, jumpDist, 127)) { - panic("CompileLandExpr: bad jump distance %d\n", jumpDist); + complete = incomplete; + incomplete = incompletePtr->p.prev; + + /* CLOSE_PAREN can only close one OPEN_PAREN. */ + if (incompletePtr->lexeme == OPEN_PAREN) { + break; + } } - objIndex = TclObjIndexForString("1", 1, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = 1; - objPtr->typePtr = &tclIntType; - - TclEmitPush(objIndex, envPtr); + /* + * More syntax checks... + */ - jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { - panic("CompileLandExpr: bad jump distance %d\n", jumpDist); + /* Parens must balance. */ + if (lexeme == CLOSE_PAREN) { + if (incompletePtr->lexeme != OPEN_PAREN) { + TclNewLiteralStringObj(msg, "unbalanced close paren"); + errCode = "UNBALANCED"; + goto error; + } } - } - /* - * Duplicate the value on top of the stack to prevent the jump from - * consuming it. - */ + /* 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"); + errCode = "SURPRISE"; + goto error; + } + } - TclEmitOpcode(INST_DUP, envPtr); + /* Operator ":" may only be right operand of "?" */ + if (IsOperator(complete) && (nodes[complete].lexeme == COLON)) { + TclNewLiteralStringObj(msg, + "unexpected operator \":\" without preceding \"?\""); + errCode = "SURPRISE"; + goto error; + } - /* - * Emit the "short circuit" jump around the rest of the landExp if - * the previous expression was false. We emit a one byte (relative) - * jump here, and replace it later with a four byte jump if the jump - * target is more than 127 bytes away. - */ + /* + * Create no node for a CLOSE_PAREN lexeme. + */ - if (jumpFixupArray.next == jumpFixupArray.end) { - TclExpandJumpFixupArray(&jumpFixupArray); - } - fixupIndex = jumpFixupArray.next; - jumpFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - &(jumpFixupArray.fixup[fixupIndex])); - - /* - * Compile the subexpression. - */ + if (lexeme == CLOSE_PAREN) { + break; + } - result = CompileBitOrExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + /* + * Link complete tree as left operand of new node. + */ - /* - * Emit a "logical and" instruction. This does not try to "short- - * circuit" the evaluation of both operands of a Tcl "&&" operator, - * but instead ensures that we either have a "1" or a "0" result. - */ + nodePtr->lexeme = lexeme; + nodePtr->precedence = precedence; + nodePtr->mark = MARK_LEFT; + nodePtr->left = complete; - TclEmitOpcode(INST_LAND, envPtr); - } + /* + * 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 */ /* - * Now that we know the target of the forward jumps, update the jumps - * with the correct distance. Also, if the distance is too great (> 127 - * bytes), replace the jump with a four byte instruction and move the - * instructions after the jump down. + * 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. */ - - for (j = jumpFixupArray.next; j > 0; j--) { - fixupIndex = (j - 1); /* process closest jump first */ - currCodeOffset = TclCurrCodeOffset(); - jumpDist = (currCodeOffset - jumpFixupArray.fixup[fixupIndex].codeOffset); - TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]), - jumpDist, 127); + + error: + if (parsePtr->errorType == TCL_PARSE_SUCCESS) { + parsePtr->errorType = TCL_PARSE_SYNTAX; } /* - * We get here only if one or more &&'s appear as top-level operators. + * Free any partial parse tree we've built. */ - done: - infoPtr->exprIsComparison = 0; - TclFreeJumpFixupArray(&jumpFixupArray); - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileBitOrExpr -- - * - * This procedure compiles a Tcl bitwise or expression: - * bitOrExpr ::= bitXorExpr {'|' bitXorExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileBitOrExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int result; - - HERE("bitOrExpr", 4); - result = CompileBitXorExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; + if (nodes != NULL) { + ckfree(nodes); } - maxDepth = envPtr->maxStackDepth; - - while (infoPtr->token == BIT_OR) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over the '|' */ - if (result != TCL_OK) { - goto done; + + 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... + */ - result = CompileBitXorExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; + if (msg == NULL) { + msg = Tcl_GetObjResult(interp); } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - TclEmitOpcode(INST_BITOR, envPtr); /* - * A comparison is not the top-level operator in this expression. + * Add a detailed quote from the bad expression, displaying and + * sometimes marking the precise location of the syntax error. */ - infoPtr->exprIsComparison = 0; - } - - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileBitXorExpr -- - * - * This procedure compiles a Tcl bitwise exclusive or expression: - * bitXorExpr ::= bitAndExpr {'^' bitAndExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ + Tcl_AppendPrintfToObj(msg, "\nin expression \"%s%.*s%.*s%s%s%.*s%s\"", + ((start - limit) < parsePtr->string) ? "" : "...", + ((start - limit) < parsePtr->string) + ? (int) (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) + ? (int) (parsePtr->end - start) - scanned : limit-3, + start + scanned, + (start + scanned + limit > parsePtr->end) ? "" : "..."); -static int -CompileBitXorExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int result; - - HERE("bitXorExpr", 5); - result = CompileBitAndExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - - while (infoPtr->token == BIT_XOR) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over the '^' */ - if (result != TCL_OK) { - goto done; - } + /* + * Next, append any postscript message. + */ - result = CompileBitAndExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; + if (post != NULL) { + Tcl_AppendToObj(msg, ";\n", -1); + Tcl_AppendObjToObj(msg, post); + Tcl_DecrRefCount(post); } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - TclEmitOpcode(INST_BITXOR, envPtr); + Tcl_SetObjResult(interp, msg); /* - * A comparison is not the top-level operator in this expression. + * Finally, place context information in the errorInfo. */ - infoPtr->exprIsComparison = 0; + numBytes = parsePtr->end - parsePtr->string; + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (parsing expression \"%.*s%s\")", + (numBytes < limit) ? numBytes : limit - 3, + parsePtr->string, (numBytes < limit) ? "" : "...")); + if (errCode) { + Tcl_SetErrorCode(interp, "TCL", "PARSE", "EXPR", errCode, + subErrCode, NULL); + } } - done: - envPtr->maxStackDepth = maxDepth; - return result; + return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * CompileBitAndExpr -- + * ConvertTreeToTokens -- * - * This procedure compiles a Tcl bitwise and expression: - * bitAndExpr ::= equalityExpr {'&' equalityExpr} + * 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: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. + * None. * * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. + * The Tcl_Parse *parsePtr is filled with Tcl_Tokens representing the + * parsed expression. * *---------------------------------------------------------------------- */ -static int -CompileBitAndExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +static void +ConvertTreeToTokens( + const char *start, + int numBytes, + OpNode *nodes, + Tcl_Token *tokenPtr, + Tcl_Parse *parsePtr) { - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int result; - - HERE("bitAndExpr", 6); - result = CompileEqualityExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - - while (infoPtr->token == BIT_AND) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over the '&' */ - if (result != TCL_OK) { - goto done; - } + int subExprTokenIdx = 0; + OpNode *nodePtr = nodes; + int next = nodePtr->right; - result = CompileEqualityExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - TclEmitOpcode(INST_BITAND, envPtr); + while (1) { + Tcl_Token *subExprTokenPtr; + int scanned, parentIdx; + unsigned char lexeme; /* - * A comparison is not the top-level operator in this expression. + * Advance the mark so the next exit from this node won't retrace + * steps over ground already covered. */ - infoPtr->exprIsComparison = 0; - } + 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); + + TclGrowParseTokenArray(parsePtr, 2); + 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. + */ + + TclGrowParseTokenArray(parsePtr, toCopy); + 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. + */ + + TclGrowParseTokenArray(parsePtr, toCopy+1); + 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. + */ + + TclGrowParseTokenArray(parsePtr, 2); + 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. + */ - done: - envPtr->maxStackDepth = maxDepth; - return result; + 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; + } + } } /* *---------------------------------------------------------------------- * - * CompileEqualityExpr -- + * Tcl_ParseExpr -- * - * This procedure compiles a Tcl equality (inequality) expression: - * equalityExpr ::= relationalExpr {('==' | '!=') relationalExpr} + * 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: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. + * 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: - * Adds instructions to envPtr to evaluate the expression at runtime. + * 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. * *---------------------------------------------------------------------- */ -static int -CompileEqualityExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +int +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 maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; - - HERE("equalityExpr", 7); - result = CompileRelationalExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; + 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 = TclStackAlloc(interp, sizeof(Tcl_Parse)); + /* Holds the Tcl_Tokens of substitutions. */ + + if (numBytes < 0) { + numBytes = (start ? strlen(start) : 0); } - maxDepth = envPtr->maxStackDepth; - - op = infoPtr->token; - while ((op == EQUAL) || (op == NEQ)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over == or != */ - if (result != TCL_OK) { - goto done; - } - - result = CompileRelationalExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - if (op == EQUAL) { - TclEmitOpcode(INST_EQ, envPtr); - } else { - TclEmitOpcode(INST_NEQ, envPtr); - } - - op = infoPtr->token; + code = ParseExpr(interp, start, numBytes, &opTree, litList, funcList, + exprParsePtr, 1 /* parseOnly */); + Tcl_DecrRefCount(funcList); + Tcl_DecrRefCount(litList); - /* - * A comparison _is_ the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 1; + 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; } - done: - envPtr->maxStackDepth = maxDepth; - return result; + Tcl_FreeParse(exprParsePtr); + TclStackFree(interp, exprParsePtr); + ckfree(opTree); + return code; } /* *---------------------------------------------------------------------- * - * CompileRelationalExpr -- + * ParseLexeme -- * - * This procedure compiles a Tcl relational expression: - * relationalExpr ::= shiftExpr {('<' | '>' | '<=' | '>=') shiftExpr} + * Parse a single lexeme from the start of a string, scanning no more + * than numBytes bytes. * * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. + * Returns the number of bytes scanned to produce the lexeme. * * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. + * Code identifying lexeme parsed is writen to *lexemePtr. * *---------------------------------------------------------------------- */ static int -CompileRelationalExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +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. */ { - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; - - HERE("relationalExpr", 8); - result = CompileShiftExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; + const char *end; + int scanned; + Tcl_UniChar ch; + Tcl_Obj *literal = NULL; + unsigned char byte; + + if (numBytes == 0) { + *lexemePtr = END; + return 0; + } + byte = UCHAR(*start); + if (byte < sizeof(Lexeme) && Lexeme[byte] != 0) { + *lexemePtr = Lexeme[byte]; + return 1; } - maxDepth = envPtr->maxStackDepth; - - op = infoPtr->token; - while ((op == LESS) || (op == GREATER) || (op == LEQ) || (op == GEQ)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over the op */ - if (result != TCL_OK) { - goto done; + switch (byte) { + case '*': + if ((numBytes > 1) && (start[1] == '*')) { + *lexemePtr = EXPON; + return 2; } + *lexemePtr = MULT; + return 1; - result = CompileShiftExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; + case '=': + if ((numBytes > 1) && (start[1] == '=')) { + *lexemePtr = EQUAL; + return 2; } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + *lexemePtr = INCOMPLETE; + return 1; - switch (op) { - case LESS: - TclEmitOpcode(INST_LT, envPtr); - break; - case GREATER: - TclEmitOpcode(INST_GT, envPtr); - break; - case LEQ: - TclEmitOpcode(INST_LE, envPtr); - break; - case GEQ: - TclEmitOpcode(INST_GE, envPtr); - break; + case '!': + if ((numBytes > 1) && (start[1] == '=')) { + *lexemePtr = NEQ; + return 2; } + *lexemePtr = NOT; + return 1; - op = infoPtr->token; + case '&': + if ((numBytes > 1) && (start[1] == '&')) { + *lexemePtr = AND; + return 2; + } + *lexemePtr = BIT_AND; + return 1; - /* - * A comparison _is_ the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 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; - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileShiftExpr -- - * - * This procedure compiles a Tcl shift expression: - * shiftExpr ::= addExpr {('<<' | '>>') addExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ + 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. + */ -static int -CompileShiftExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; - - HERE("shiftExpr", 9); - result = CompileAddExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - - op = infoPtr->token; - while ((op == LEFT_SHIFT) || (op == RIGHT_SHIFT)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over << or >> */ - if (result != TCL_OK) { - goto done; + *lexemePtr = IN_LIST; + return 2; } + break; - result = CompileAddExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; + case 'e': + if ((numBytes > 1) && (start[1] == 'q') + && ((numBytes == 2) || !isalpha(UCHAR(start[2])))) { + *lexemePtr = STREQ; + return 2; } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + break; - if (op == LEFT_SHIFT) { - TclEmitOpcode(INST_LSHIFT, envPtr); - } else { - TclEmitOpcode(INST_RSHIFT, envPtr); + 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; + } } + } - op = infoPtr->token; + literal = Tcl_NewObj(); + if (TclParseNumber(NULL, literal, NULL, start, numBytes, &end, + TCL_PARSE_NO_WHITESPACE) == TCL_OK) { + if (end < start + numBytes && !isalnum(UCHAR(*end)) + && UCHAR(*end) != '_') { + + number: + TclInitStringRep(literal, start, end-start); + *lexemePtr = NUMBER; + if (literalPtr) { + *literalPtr = literal; + } else { + Tcl_DecrRefCount(literal); + } + return (end-start); + } else { + unsigned char lexeme; - /* - * A comparison is not the top-level operator in this expression. - */ + /* + * We have a number followed directly by bareword characters + * (alpha, digit, underscore). Is this a number followed by + * bareword syntax error? Or should we join into one bareword? + * Example: Inf + luence + () becomes a valid function call. + * [Bug 3401704] + */ + if (literal->typePtr == &tclDoubleType) { + const char *p = start; + + while (p < end) { + if (!isalnum(UCHAR(*p++))) { + /* + * The number has non-bareword characters, so we + * must treat it as a number. + */ + goto number; + } + } + } + ParseLexeme(end, numBytes-(end-start), &lexeme, NULL); + if ((NODE_TYPE & lexeme) == BINARY) { + /* + * The bareword characters following the number take the + * form of an operator (eq, ne, in, ni, ...) so we treat + * as number + operator. + */ + goto number; + } + + /* + * Otherwise, fall through and parse the whole as a bareword. + */ + } + } - infoPtr->exprIsComparison = 0; + 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 (!isalnum(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]; - done: - envPtr->maxStackDepth = maxDepth; - return result; + 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); } /* *---------------------------------------------------------------------- * - * CompileAddExpr -- + * TclCompileExpr -- * - * This procedure compiles a Tcl addition expression: - * addExpr ::= multiplyExpr {('+' | '-') multiplyExpr} + * This procedure compiles a string containing a Tcl expression into Tcl + * bytecodes. * * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. + * None. * * Side effects: * Adds instructions to envPtr to evaluate the expression at runtime. @@ -1330,1057 +2109,699 @@ CompileShiftExpr(interp, infoPtr, flags, envPtr) *---------------------------------------------------------------------- */ -static int -CompileAddExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +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. */ + int optimize) /* 0 for one-off expressions. */ { - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; - - HERE("addExpr", 10); - result = CompileMultiplyExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - - op = infoPtr->token; - while ((op == PLUS) || (op == MINUS)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over + or - */ - if (result != TCL_OK) { - goto done; - } - - result = CompileMultiplyExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - if (op == PLUS) { - TclEmitOpcode(INST_ADD, envPtr); - } else { - TclEmitOpcode(INST_SUB, envPtr); - } + 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 = TclStackAlloc(interp, sizeof(Tcl_Parse)); + /* Holds the Tcl_Tokens of substitutions */ - op = infoPtr->token; + int code = ParseExpr(interp, script, numBytes, &opTree, litList, + funcList, parsePtr, 0 /* parseOnly */); + if (code == TCL_OK) { /* - * A comparison is not the top-level operator in this expression. + * Valid parse; compile the tree. */ - infoPtr->exprIsComparison = 0; + 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, optimize); + } else { + TclCompileSyntaxError(interp, envPtr); } - done: - envPtr->maxStackDepth = maxDepth; - return result; + Tcl_FreeParse(parsePtr); + TclStackFree(interp, parsePtr); + Tcl_DecrRefCount(funcList); + Tcl_DecrRefCount(litList); + ckfree(opTree); } /* *---------------------------------------------------------------------- * - * CompileMultiplyExpr -- - * - * This procedure compiles a Tcl multiply expression: - * multiplyExpr ::= unaryExpr {('*' | '/' | '%') unaryExpr} + * 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: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. + * A standard Tcl return code and result left in interp. * * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. + * Consumes subtree of nodes rooted at index. Advances the pointer + * *litObjvPtr. * *---------------------------------------------------------------------- */ static int -CompileMultiplyExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +ExecConstantExprTree( + Tcl_Interp *interp, + OpNode *nodes, + int index, + Tcl_Obj *const **litObjvPtr) { - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; - - HERE("multiplyExpr", 11); - result = CompileUnaryExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - - op = infoPtr->token; - while ((op == MULT) || (op == DIVIDE) || (op == MOD)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over * or / */ - if (result != TCL_OK) { - goto done; - } - - result = CompileUnaryExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - if (op == MULT) { - TclEmitOpcode(INST_MULT, envPtr); - } else if (op == DIVIDE) { - TclEmitOpcode(INST_DIV, envPtr); - } else { - TclEmitOpcode(INST_MOD, envPtr); - } + CompileEnv *envPtr; + ByteCode *byteCodePtr; + int code; + Tcl_Obj *byteCodeObj = Tcl_NewObj(); + NRE_callback *rootPtr = TOP_CB(interp); - op = infoPtr->token; - - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; - } + /* + * 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. + */ - done: - envPtr->maxStackDepth = maxDepth; - return result; + envPtr = 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 = byteCodeObj->internalRep.twoPtrValue.ptr1; + TclNRExecuteByteCode(interp, byteCodePtr); + code = TclNRRunCallbacks(interp, TCL_OK, rootPtr); + Tcl_DecrRefCount(byteCodeObj); + return code; } /* *---------------------------------------------------------------------- * - * CompileUnaryExpr -- + * CompileExprTree -- * - * This procedure compiles a Tcl unary expression: - * unaryExpr ::= ('+' | '-' | '~' | '!') unaryExpr | primaryExpr + * 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: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. + * None. * * Side effects: * Adds instructions to envPtr to evaluate the expression at runtime. + * Consumes subtree of nodes rooted at index. Advances the pointer + * *litObjvPtr. * *---------------------------------------------------------------------- */ -static int -CompileUnaryExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +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) { - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; - - HERE("unaryExpr", 12); - op = infoPtr->token; - if ((op == PLUS) || (op == MINUS) || (op == BIT_NOT) || (op == NOT)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over the op */ - if (result != TCL_OK) { - goto done; - } + 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; + + if (nodePtr->lexeme == QUESTION) { + convert = 1; + } + } 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); + TclDStringAppendLiteral(&cmdName, "tcl::mathfunc::"); + p = TclGetStringFromObj(*funcObjv, &length); + funcObjv++; + Tcl_DStringAppend(&cmdName, p, length); + TclEmitPush(TclRegisterNewCmdLiteral(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: + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); + break; + case COLON: + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, + &jumpPtr->jump); + TclAdjustStackDepth(-1, envPtr); + if (convert) { + jumpPtr->jump.jumpType = TCL_TRUE_JUMP; + } + convert = 1; + break; + case AND: + case OR: + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; + TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) + ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, &jumpPtr->jump); + break; + } + } else { + int pc1, pc2, target; + + 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) { + TclEmitInvoke(envPtr, INST_INVOKE_STK1, numWords); + } else { + TclEmitInvoke(envPtr, INST_INVOKE_STK4, numWords); + } + + /* + * Restore any saved numWords value. + */ - result = CompileUnaryExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; + numWords = nodePtr->left; + convert = 1; + break; + case COMMA: + /* + * Each comma implies another function argument. + */ + + numWords++; + break; + case COLON: + CLANG_ASSERT(jumpPtr); + if (jumpPtr->jump.jumpType == TCL_TRUE_JUMP) { + jumpPtr->jump.jumpType = TCL_UNCONDITIONAL_JUMP; + convert = 1; + } + target = jumpPtr->jump.codeOffset + 2; + if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { + target += 3; + } + freePtr = jumpPtr; + jumpPtr = jumpPtr->next; + TclStackFree(interp, freePtr); + TclFixupForwardJump(envPtr, &jumpPtr->jump, + target - jumpPtr->jump.codeOffset, 127); + + freePtr = jumpPtr; + jumpPtr = jumpPtr->next; + TclStackFree(interp, freePtr); + break; + case AND: + case OR: + CLANG_ASSERT(jumpPtr); + pc1 = CurrentOffset(envPtr); + TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1 + : INST_JUMP_TRUE1, 0, envPtr); + TclEmitPush(TclRegisterNewLiteral(envPtr, + (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr); + pc2 = CurrentOffset(envPtr); + TclEmitInstInt1(INST_JUMP1, 0, envPtr); + TclAdjustStackDepth(-1, envPtr); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc1, + envPtr->codeStart + pc1 + 1); + if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { + pc2 += 3; + } + TclEmitPush(TclRegisterNewLiteral(envPtr, + (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2, + envPtr->codeStart + pc2 + 1); + convert = 0; + 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; } - maxDepth = envPtr->maxStackDepth; - switch (op) { - case PLUS: - TclEmitOpcode(INST_UPLUS, envPtr); - break; - case MINUS: - TclEmitOpcode(INST_UMINUS, envPtr); - break; - case BIT_NOT: - TclEmitOpcode(INST_BITNOT, envPtr); + nodePtr->mark++; + switch (next) { + case OT_EMPTY: + numWords = 1; /* No arguments, so just the command */ break; - case NOT: - TclEmitOpcode(INST_LNOT, envPtr); + case OT_LITERAL: { + Tcl_Obj *const *litObjv = *litObjvPtr; + Tcl_Obj *literal = *litObjv; + + if (optimize) { + int length; + const char *bytes = TclGetStringFromObj(literal, &length); + int index = TclRegisterNewLiteral(envPtr, bytes, length); + Tcl_Obj *objPtr = TclFetchLiteral(envPtr, index); + + if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) { + /* + * Would like to do 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 change. So rather than replace lePtr->objPtr, we do + * surgery to transfer our desired intrep into it. + */ + + objPtr->typePtr = literal->typePtr; + objPtr->internalRep = literal->internalRep; + literal->typePtr = NULL; + } + TclEmitPush(index, envPtr); + } else { + /* + * When optimize==0, we know the expression is a one-off and + * there's nothing to be gained from sharing literals when + * they won't live long, and the copies we have already have + * an appropriate intrep. In this case, skip literal + * registration that would enable sharing, and use the routine + * that preserves intreps. + */ + + TclEmitPush(TclAddLiteralObj(envPtr, literal, NULL), envPtr); + } + (*litObjvPtr)++; break; } - - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; - } else { /* must be a primaryExpr */ - result = CompilePrimaryExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; + case OT_TOKENS: + CompileTokens(envPtr, tokenPtr, interp); + 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) { + int index; + Tcl_Obj *objPtr = Tcl_GetObjResult(interp); + + /* + * Don't generate a string rep, but if we have one + * already, then use it to share via the literal table. + */ + + if (objPtr->bytes) { + Tcl_Obj *tableValue; + + index = TclRegisterNewLiteral(envPtr, objPtr->bytes, + objPtr->length); + tableValue = TclFetchLiteral(envPtr, index); + if ((tableValue->typePtr == NULL) && + (objPtr->typePtr != NULL)) { + /* + * Same intrep surgery as for OT_LITERAL. + */ + + tableValue->typePtr = objPtr->typePtr; + tableValue->internalRep = objPtr->internalRep; + objPtr->typePtr = NULL; + } + } else { + index = TclAddLiteralObj(envPtr, objPtr, NULL); + } + TclEmitPush(index, envPtr); + } else { + TclCompileSyntaxError(interp, envPtr); + } + Tcl_RestoreInterpState(interp, save); + convert = 0; + } else { + nodePtr = nodes + next; + } } - maxDepth = envPtr->maxStackDepth; } - - done: - envPtr->maxStackDepth = maxDepth; - return result; } /* *---------------------------------------------------------------------- * - * CompilePrimaryExpr -- + * TclSingleOpCmd -- * - * This procedure compiles a Tcl primary expression: - * primaryExpr ::= literal | varReference | quotedString | - * '[' command ']' | mathFuncCall | '(' condExpr ')' + * 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: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. + * A standard Tcl return code and result left in interp. * * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. + * None. * *---------------------------------------------------------------------- */ -static int -CompilePrimaryExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +int +TclSingleOpCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) { - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int theToken; - char *dollarPtr, *quotePtr, *cmdPtr, *termPtr; - int result = TCL_OK; - - /* - * We emit tryCvtToNumeric instructions after most of these primary - * expressions in order to support Tcl's policy of interpreting operands - * as first integers if possible, otherwise floating-point numbers if - * possible. - */ - - HERE("primaryExpr", 13); - theToken = infoPtr->token; - - if ((theToken != DOLLAR) && (theToken != OPEN_PAREN)) { - infoPtr->exprIsJustVarRef = 0; - } - switch (theToken) { - case LITERAL: /* int, double, or string in braces */ - TclEmitPush(infoPtr->objIndex, envPtr); - maxDepth = 1; - break; - - case DOLLAR: /* $var variable reference */ - dollarPtr = (infoPtr->next - 1); - envPtr->pushSimpleWords = 1; - result = TclCompileDollarVar(interp, dollarPtr, - infoPtr->lastChar, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - infoPtr->next = (dollarPtr + envPtr->termOffset); - break; - - case QUOTE: /* quotedString */ - quotePtr = infoPtr->next; - envPtr->pushSimpleWords = 1; - result = TclCompileQuotes(interp, quotePtr, - infoPtr->lastChar, '"', flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - infoPtr->next = (quotePtr + envPtr->termOffset); - break; - - case OPEN_BRACKET: /* '[' command ']' */ - cmdPtr = infoPtr->next; - envPtr->pushSimpleWords = 1; - result = TclCompileString(interp, cmdPtr, - infoPtr->lastChar, (flags | TCL_BRACKET_TERM), envPtr); - if (result != TCL_OK) { - goto done; - } - termPtr = (cmdPtr + envPtr->termOffset); - if (*termPtr == ']') { - infoPtr->next = (termPtr + 1); /* advance over the ']'. */ - } else if (termPtr == infoPtr->lastChar) { - /* - * Missing ] at end of nested command. - */ - - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "missing close-bracket", -1); - result = TCL_ERROR; - goto done; - } else { - panic("CompilePrimaryExpr: unexpected termination char '%c' for nested command\n", *termPtr); - } - maxDepth = envPtr->maxStackDepth; - break; - - case FUNC_NAME: - result = CompileMathFuncCall(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - break; - - case OPEN_PAREN: - result = GetToken(interp, infoPtr, envPtr); /* skip over the '(' */ - if (result != TCL_OK) { - goto done; - } - infoPtr->exprIsComparison = 0; - result = CompileCondExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - if (infoPtr->token != CLOSE_PAREN) { - goto syntaxError; - } - break; - - default: - goto syntaxError; + TclOpCmdClientData *occdPtr = 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; } - if (theToken != FUNC_NAME) { - /* - * Advance to the next token before returning. - */ - - result = GetToken(interp, infoPtr, envPtr); - if (result != TCL_OK) { - goto done; - } + ParseLexeme(occdPtr->op, strlen(occdPtr->op), &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; - done: - envPtr->maxStackDepth = maxDepth; - return result; - - syntaxError: - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "syntax error in expression \"", infoPtr->originalExpr, - "\"", (char *) NULL); - return TCL_ERROR; + return ExecConstantExprTree(interp, nodes, 0, &litObjv); } /* *---------------------------------------------------------------------- * - * CompileMathFuncCall -- - * - * This procedure compiles a call on a math function in an expression: - * mathFuncCall ::= funcName '(' [condExpr {',' condExpr}] ')' + * 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: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the function. + * A standard Tcl return code and result left in interp. * * Side effects: - * Adds instructions to envPtr to evaluate the math function at - * runtime. + * None. * *---------------------------------------------------------------------- */ -static int -CompileMathFuncCall(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +int +TclSortingOpCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - MathFunc *mathFuncPtr; /* Info about math function. */ - int objIndex; /* The object array index for an object - * holding the function name if it is not - * builtin. */ - Tcl_HashEntry *hPtr; - char *p, *funcName; - char savedChar; - int result, i; - - /* - * infoPtr->funcName points to the first character of the math - * function's name. Look for the end of its name and look up the - * MathFunc record for the function. - */ - - funcName = p = infoPtr->funcName; - while (isalnum(UCHAR(*p)) || (*p == '_')) { - p++; - } - infoPtr->next = p; - - result = GetToken(interp, infoPtr, envPtr); /* skip over func name */ - if (result != TCL_OK) { - goto done; - } - if (infoPtr->token != OPEN_PAREN) { - goto syntaxError; - } - result = GetToken(interp, infoPtr, envPtr); /* skip over '(' */ - if (result != TCL_OK) { - goto done; - } - - savedChar = *p; - *p = 0; - hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); - if (hPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown math function \"", funcName, "\"", (char *) NULL); - result = TCL_ERROR; - *p = savedChar; - goto done; - } - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - - /* - * If not a builtin function, push an object with the function's name. - */ - - if (mathFuncPtr->builtinFuncIndex < 0) { /* not builtin */ - objIndex = TclObjIndexForString(funcName, -1, /*allocStrRep*/ 1, - /*inHeap*/ 0, envPtr); - TclEmitPush(objIndex, envPtr); - maxDepth = 1; - } - - /* - * Restore the saved character after the function name. - */ + int code = TCL_OK; - *p = savedChar; - - /* - * Compile the arguments for the function, if there are any. - */ - - if (mathFuncPtr->numArgs > 0) { - for (i = 0; ; i++) { - infoPtr->exprIsComparison = 0; - result = CompileCondExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - - /* - * Check for a ',' between arguments or a ')' ending the - * argument list. - */ - - if (i == (mathFuncPtr->numArgs-1)) { - if (infoPtr->token == CLOSE_PAREN) { - break; /* exit the argument parsing loop */ - } else if (infoPtr->token == COMMA) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "too many arguments for math function", -1); - result = TCL_ERROR; - goto done; - } else { - goto syntaxError; - } - } - if (infoPtr->token != COMMA) { - if (infoPtr->token == CLOSE_PAREN) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "too few arguments for math function", -1); - result = TCL_ERROR; - goto done; - } else { - goto syntaxError; - } - } - result = GetToken(interp, infoPtr, envPtr); /* skip over , */ - if (result != TCL_OK) { - goto done; - } - maxDepth++; + if (objc < 3) { + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); + } else { + TclOpCmdClientData *occdPtr = clientData; + Tcl_Obj **litObjv = TclStackAlloc(interp, + 2 * (objc-2) * sizeof(Tcl_Obj *)); + OpNode *nodes = TclStackAlloc(interp, 2 * (objc-2) * sizeof(OpNode)); + unsigned char lexeme; + int i, lastAnd = 1; + Tcl_Obj *const *litObjPtrPtr = litObjv; + + ParseLexeme(occdPtr->op, strlen(occdPtr->op), &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); } - } - - if (infoPtr->token != CLOSE_PAREN) { - goto syntaxError; - } - result = GetToken(interp, infoPtr, envPtr); /* skip over ')' */ - if (result != TCL_OK) { - goto done; - } - - /* - * Compile the call on the math function. Note that the "objc" argument - * count for non-builtin functions is incremented by 1 to include the - * the function name itself. - */ + litObjv[2*(objc-2)-1] = objv[objc-1]; - if (mathFuncPtr->builtinFuncIndex >= 0) { /* a builtin function */ - TclEmitInstUInt1(INST_CALL_BUILTIN_FUNC1, - mathFuncPtr->builtinFuncIndex, envPtr); - } else { - TclEmitInstUInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr); - } + 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; - /* - * A comparison is not the top-level operator in this expression. - */ + nodes[0].right = lastAnd; + nodes[lastAnd].p.parent = 0; - done: - infoPtr->exprIsComparison = 0; - envPtr->maxStackDepth = maxDepth; - return result; + code = ExecConstantExprTree(interp, nodes, 0, &litObjPtrPtr); - syntaxError: - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "syntax error in expression \"", infoPtr->originalExpr, - "\"", (char *) NULL); - return TCL_ERROR; + TclStackFree(interp, nodes); + TclStackFree(interp, litObjv); + } + return code; } /* *---------------------------------------------------------------------- * - * GetToken -- - * - * Lexical scanner used to compile expressions: parses a single - * operator or other syntactic element from an expression string. + * 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: - * TCL_OK is returned unless an error occurred. In that case a standard - * Tcl error is returned, using the interpreter's result to hold an - * error message. TCL_ERROR is returned if an integer overflow, or a - * floating-point overflow or underflow occurred while reading in a - * number. If the lexical analysis is successful, infoPtr->token refers - * to the next symbol in the expression string, and infoPtr->next is - * advanced past the token. Also, if the token is a integer, double, or - * string literal, then infoPtr->objIndex the index of an object - * holding the value in the code's object table; otherwise is NULL. + * A standard Tcl return code and result left in interp. * * Side effects: - * Object are added to envPtr to hold the values of scanned literal - * integers, doubles, or strings. + * None. * *---------------------------------------------------------------------- */ -static int -GetToken(interp, infoPtr, envPtr) - Tcl_Interp *interp; /* Interpreter to use for error - * reporting. */ - register ExprInfo *infoPtr; /* Describes the state of the - * compiling the expression, - * including the resulting token. */ - CompileEnv *envPtr; /* Holds objects that store literal - * values that are scanned. */ +int +TclVariadicOpCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) { - register char *src; /* Points to current source char. */ - register char c; /* The current char. */ - register int type; /* Current char's CHAR_TYPE type. */ - char *termPtr; /* Points to char terminating a literal. */ - char savedChar; /* Holds the character termporarily replaced - * by a null character during processing of - * literal tokens. */ - int objIndex; /* The object array index for an object - * holding a scanned literal. */ - long longValue; /* Value of a scanned integer literal. */ - double doubleValue; /* Value of a scanned double literal. */ - Tcl_Obj *objPtr; - - /* - * First initialize the scanner's "result" fields to default values. - */ - - infoPtr->token = UNKNOWN; - infoPtr->objIndex = -1; - infoPtr->funcName = NULL; + TclOpCmdClientData *occdPtr = clientData; + unsigned char lexeme; + int code; - /* - * Scan over leading white space at the start of a token. Note that a - * backslash-newline is treated as a space. - */ - - src = infoPtr->next; - c = *src; - type = CHAR_TYPE(src, infoPtr->lastChar); - while ((type & (TCL_SPACE | TCL_BACKSLASH)) || (c == '\n')) { - if (type == TCL_BACKSLASH) { - if (src[1] == '\n') { - src += 2; - } else { - break; /* no longer white space */ - } - } else { - src++; - } - c = *src; - type = CHAR_TYPE(src, infoPtr->lastChar); - } - if (src == infoPtr->lastChar) { - infoPtr->token = END; - infoPtr->next = src; + if (objc < 2) { + Tcl_SetObjResult(interp, Tcl_NewIntObj(occdPtr->i.identity)); return TCL_OK; } - /* - * Try to parse the token first as an integer or floating-point - * number. Don't check for a number if the first character is "+" or - * "-". If we did, we might treat a binary operator as unary by mistake, - * which would eventually cause a syntax error. - */ - - if ((*src != '+') && (*src != '-')) { - int startsWithDigit = isdigit(UCHAR(*src)); - - if (startsWithDigit && TclLooksLikeInt(src)) { - errno = 0; - longValue = strtoul(src, &termPtr, 0); - if (errno == ERANGE) { - char *s = "integer value too large to represent"; - - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, - (char *) NULL); - return TCL_ERROR; - } - if (termPtr != src) { - /* - * src was the start of a valid integer. Find/create an - * object in envPtr's object array to contain the integer. - */ - - savedChar = *termPtr; - *termPtr = '\0'; - objIndex = TclObjIndexForString(src, termPtr - src, - /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr); - *termPtr = savedChar; /* restore the saved char */ - - objPtr = envPtr->objArrayPtr[objIndex]; - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = longValue; - objPtr->typePtr = &tclIntType; - - infoPtr->token = LITERAL; - infoPtr->objIndex = objIndex; - infoPtr->next = termPtr; - return TCL_OK; - } - } else if (startsWithDigit || (*src == '.') - || (*src == 'n') || (*src == 'N')) { - errno = 0; - doubleValue = strtod(src, &termPtr); - if (termPtr != src) { - if (errno != 0) { - TclExprFloatError(interp, doubleValue); - return TCL_ERROR; - } - - /* - * Find/create an object in the object array containing the - * double. - */ - - savedChar = *termPtr; - *termPtr = '\0'; - objIndex = TclObjIndexForString(src, termPtr - src, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - *termPtr = savedChar; /* restore the saved char */ - - objPtr = envPtr->objArrayPtr[objIndex]; - objPtr->internalRep.doubleValue = doubleValue; - objPtr->typePtr = &tclDoubleType; - - infoPtr->token = LITERAL; - infoPtr->objIndex = objIndex; - infoPtr->next = termPtr; - return TCL_OK; + ParseLexeme(occdPtr->op, strlen(occdPtr->op), &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; } - } - /* - * Not an integer or double literal. Check next for a string literal - * in braces. - */ - - if (*src == '{') { - int level = 0; /* The {} nesting level. */ - int hasBackslashNL = 0; /* Nonzero if '\newline' was found. */ - char *string = src; /* Set below to point just after the - * starting '{'. */ - char *last; /* Points just before terminating '}'. */ - int numChars; /* Number of chars in braced string. */ - char savedChar; /* Holds the character from string - * termporarily replaced by a null char - * during braced string processing. */ - int numRead; - - /* - * Check first for any backslash-newlines, since we must treat - * backslash-newlines specially (they must be replaced by spaces). - */ + code = ExecConstantExprTree(interp, nodes, 0, &litObjPtrPtr); - while (1) { - if (src == infoPtr->lastChar) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "missing close-brace", -1); - return TCL_ERROR; - } else if (CHAR_TYPE(src, infoPtr->lastChar) == TCL_NORMAL) { - src++; - continue; - } - c = *src++; - if (c == '{') { - level++; - } else if (c == '}') { - --level; - if (level == 0) { - last = (src - 2); /* i.e. just before terminating } */ - break; - } - } else if (c == '\\') { - if (*src == '\n') { - hasBackslashNL = 1; + Tcl_DecrRefCount(litObjv[decrMe]); + return code; + } else { + Tcl_Obj *const *litObjv = objv + 1; + OpNode *nodes = 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; } - (void) Tcl_Backslash(src-1, &numRead); - src += numRead - 1; + lastOp = i; } - } - - /* - * Create a string object for the braced string. This will start at - * "string" and ends just after "last" (which points to the final - * character before the terminating '}'). If backslash-newlines were - * found, we copy characters one at a time into a heap-allocated - * buffer and do backslash-newline substitutions. - */ - - string++; - numChars = (last - string + 1); - savedChar = string[numChars]; - string[numChars] = '\0'; - if (hasBackslashNL && (numChars > 0)) { - char *buffer = ckalloc((unsigned) numChars + 1); - register char *dst = buffer; - register char *p = string; - while (p <= last) { - c = *dst++ = *p++; - if (c == '\\') { - if (*p == '\n') { - dst[-1] = Tcl_Backslash(p-1, &numRead); - p += numRead - 1; - } else { - (void) Tcl_Backslash(p-1, &numRead); - while (numRead > 1) { - *dst++ = *p++; - numRead--; - } - } + } 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; } - *dst = '\0'; - objIndex = TclObjIndexForString(buffer, dst - buffer, - /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr); - } else { - objIndex = TclObjIndexForString(string, numChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); } - string[numChars] = savedChar; /* restore the saved char */ - - infoPtr->token = LITERAL; - infoPtr->objIndex = objIndex; - infoPtr->next = src; - return TCL_OK; - } - - /* - * Not an literal value. - */ - - infoPtr->next = src+1; /* assume a 1 char token and advance over it */ - switch (*src) { - case '[': - infoPtr->token = OPEN_BRACKET; - return TCL_OK; - - case ']': - infoPtr->token = CLOSE_BRACKET; - return TCL_OK; - - case '(': - infoPtr->token = OPEN_PAREN; - return TCL_OK; - - case ')': - infoPtr->token = CLOSE_PAREN; - return TCL_OK; - - case '$': - infoPtr->token = DOLLAR; - return TCL_OK; - - case '"': - infoPtr->token = QUOTE; - return TCL_OK; - - case ',': - infoPtr->token = COMMA; - return TCL_OK; - - case '*': - infoPtr->token = MULT; - return TCL_OK; - - case '/': - infoPtr->token = DIVIDE; - return TCL_OK; - - case '%': - infoPtr->token = MOD; - return TCL_OK; - - case '+': - infoPtr->token = PLUS; - return TCL_OK; - - case '-': - infoPtr->token = MINUS; - return TCL_OK; - - case '?': - infoPtr->token = QUESTY; - return TCL_OK; - - case ':': - infoPtr->token = COLON; - return TCL_OK; - - case '<': - switch (src[1]) { - case '<': - infoPtr->next = src+2; - infoPtr->token = LEFT_SHIFT; - break; - case '=': - infoPtr->next = src+2; - infoPtr->token = LEQ; - break; - default: - infoPtr->token = LESS; - break; - } - return TCL_OK; - - case '>': - switch (src[1]) { - case '>': - infoPtr->next = src+2; - infoPtr->token = RIGHT_SHIFT; - break; - case '=': - infoPtr->next = src+2; - infoPtr->token = GEQ; - break; - default: - infoPtr->token = GREATER; - break; - } - return TCL_OK; - - case '=': - if (src[1] == '=') { - infoPtr->next = src+2; - infoPtr->token = EQUAL; - } else { - infoPtr->token = UNKNOWN; - } - return TCL_OK; - - case '!': - if (src[1] == '=') { - infoPtr->next = src+2; - infoPtr->token = NEQ; - } else { - infoPtr->token = NOT; - } - return TCL_OK; - - case '&': - if (src[1] == '&') { - infoPtr->next = src+2; - infoPtr->token = AND; - } else { - infoPtr->token = BIT_AND; - } - return TCL_OK; + nodes[0].right = lastOp; + nodes[lastOp].p.parent = 0; - case '^': - infoPtr->token = BIT_XOR; - return TCL_OK; + code = ExecConstantExprTree(interp, nodes, 0, &litObjv); - case '|': - if (src[1] == '|') { - infoPtr->next = src+2; - infoPtr->token = OR; - } else { - infoPtr->token = BIT_OR; - } - return TCL_OK; - - case '~': - infoPtr->token = BIT_NOT; - return TCL_OK; - - default: - if (isalpha(UCHAR(*src))) { - infoPtr->token = FUNC_NAME; - infoPtr->funcName = src; - while (isalnum(UCHAR(*src)) || (*src == '_')) { - src++; - } - infoPtr->next = src; - return TCL_OK; - } - infoPtr->next = src+1; - infoPtr->token = UNKNOWN; - return TCL_OK; + TclStackFree(interp, nodes); + return code; } } /* *---------------------------------------------------------------------- * - * Tcl_CreateMathFunc -- - * - * Creates a new math function for expressions in a given - * interpreter. + * 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: - * None. + * A standard Tcl return code and result left in interp. * * Side effects: - * The function defined by "name" is created or redefined. If the - * function already exists then its definition is replaced; this - * includes the builtin functions. Redefining a builtin function forces - * all existing code to be invalidated since that code may be compiled - * using an instruction specific to the replaced function. In addition, - * redefioning a non-builtin function will force existing code to be - * invalidated if the number of arguments has changed. + * None. * *---------------------------------------------------------------------- */ -void -Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) - Tcl_Interp *interp; /* Interpreter in which function is - * to be available. */ - char *name; /* Name of function (e.g. "sin"). */ - int numArgs; /* Nnumber of arguments required by - * function. */ - Tcl_ValueType *argTypes; /* Array of types acceptable for - * each argument. */ - Tcl_MathProc *proc; /* Procedure that implements the - * math function. */ - ClientData clientData; /* Additional value to pass to the - * function. */ +int +TclNoIdentOpCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hPtr; - MathFunc *mathFuncPtr; - int new, i; - - hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new); - if (new) { - Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc))); - } - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); + TclOpCmdClientData *occdPtr = clientData; - if (!new) { - if (mathFuncPtr->builtinFuncIndex >= 0) { - /* - * We are redefining a builtin math function. Invalidate the - * interpreter's existing code by incrementing its - * compileEpoch member. This field is checked in Tcl_EvalObj - * and ObjInterpProc, and code whose compilation epoch doesn't - * match is recompiled. Newly compiled code will no longer - * treat the function as builtin. - */ - - iPtr->compileEpoch++; - } else { - /* - * A non-builtin function is being redefined. We must invalidate - * existing code if the number of arguments has changed. This - * is because existing code was compiled assuming that number. - */ - - if (numArgs != mathFuncPtr->numArgs) { - iPtr->compileEpoch++; - } - } - } - - mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */ - if (numArgs > MAX_MATH_ARGS) { - numArgs = MAX_MATH_ARGS; + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected); + return TCL_ERROR; } - mathFuncPtr->numArgs = numArgs; - for (i = 0; i < numArgs; i++) { - mathFuncPtr->argTypes[i] = argTypes[i]; - } - mathFuncPtr->proc = proc; - mathFuncPtr->clientData = clientData; + return TclVariadicOpCmd(clientData, interp, objc, objv); } +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |