diff options
Diffstat (limited to 'generic/tclCompExpr.c')
| -rw-r--r-- | generic/tclCompExpr.c | 3229 |
1 files changed, 2482 insertions, 747 deletions
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 68533c5..60f95b6 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -1,578 +1,2020 @@ -/* +/* * tclCompExpr.c -- * - * This file contains the code to compile Tcl expressions. + * 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::+ . * - * Copyright (c) 1997 Sun Microsystems, Inc. - * Copyright (c) 1998-2000 by Scriptics Corporation. + * Contributions from Don Porter, NIST, 2006-2007. (not subject to US copyright) * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * 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; + +/* + * 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. + */ -#ifdef NO_ERRNO_H -extern int errno; /* Use errno from tclExecute.c. */ -#define ERANGE 34 -#endif +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 traceExprComp = 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 { - Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Structure filled with information about - * the parsed expression. */ - CONST char *expr; /* The expression that was originally passed - * to TclCompileExpr. */ - CONST char *lastChar; /* Points just after last byte of expr. */ - 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. */ -} 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 numeric codes representing each expression operator. - * The order of these must match the entries in the operatorTable below. - * Also the codes for the relational operators (OP_LESS, OP_GREATER, - * OP_LE, OP_GE, OP_EQ, and OP_NE) must be consecutive and in that order. - * Note that OP_PLUS and OP_MINUS represent both unary and binary operators. + * 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 OP_MULT 0 -#define OP_DIVIDE 1 -#define OP_MOD 2 -#define OP_PLUS 3 -#define OP_MINUS 4 -#define OP_LSHIFT 5 -#define OP_RSHIFT 6 -#define OP_LESS 7 -#define OP_GREATER 8 -#define OP_LE 9 -#define OP_GE 10 -#define OP_EQ 11 -#define OP_NEQ 12 -#define OP_BITAND 13 -#define OP_BITXOR 14 -#define OP_BITOR 15 -#define OP_LAND 16 -#define OP_LOR 17 -#define OP_QUESTY 18 -#define OP_LNOT 19 -#define OP_BITNOT 20 -#define OP_STREQ 21 -#define OP_STRNEQ 22 +/* + * Each lexeme belongs to one of four categories, which determine + * its place in the parse tree. We use the two high bits of the + * (unsigned char) value to store a NODE_TYPE code. + */ + +#define NODE_TYPE 0xC0 + +/* + * The four category values are LEAF, UNARY, and BINARY, explained below, + * and "uncategorized", which is used either temporarily, until context + * determines which of the other three categories is correct, or for + * lexemes like INVALID, which aren't really lexemes at all, but indicators + * of a parsing error. Note that the codes must be distinct to distinguish + * categories, but need not take the form of a bit array. + */ +#define BINARY 0x40 /* This lexeme is a binary operator. An + * OpNode representing it should go into the + * parse tree, and two operands should be + * parsed for it in the expression. */ +#define UNARY 0x80 /* This lexeme is a unary operator. An OpNode + * representing it should go into the parse + * tree, and one operand should be parsed for + * it in the expression. */ +#define LEAF 0xC0 /* This lexeme is a leaf operand in the parse + * tree. No OpNode will be placed in the tree + * for it. Either a literal value will be + * appended to the list of literals in this + * expression, or appropriate Tcl_Tokens will + * be appended in a Tcl_Parse struct to + * represent those leaves that require some + * form of substitution. + */ + +/* Uncategorized lexemes */ + +#define PLUS 1 /* Ambiguous. Resolves to UNARY_PLUS or + * BINARY_PLUS according to context. */ +#define MINUS 2 /* Ambiguous. Resolves to UNARY_MINUS or + * BINARY_MINUS according to context. */ +#define BAREWORD 3 /* Ambigous. Resolves to BOOLEAN or to + * FUNCTION or a parse error according to + * context and value. */ +#define INCOMPLETE 4 /* A parse error. Used only when the single + * "=" is encountered. */ +#define INVALID 5 /* A parse error. Used when any punctuation + * appears that's not a supported operator. */ + +/* Leaf lexemes */ + +#define NUMBER ( LEAF | 1) /* For literal numbers */ +#define SCRIPT ( LEAF | 2) /* Script substitution; [foo] */ +#define BOOLEAN ( LEAF | BAREWORD) /* For literal booleans */ +#define BRACED ( LEAF | 4) /* Braced string; {foo bar} */ +#define VARIABLE ( LEAF | 5) /* Variable substitution; $x */ +#define QUOTED ( LEAF | 6) /* Quoted string; "foo $bar [soom]" */ +#define EMPTY ( LEAF | 7) /* Used only for an empty argument + * list to a function. Represents + * the empty string within parens in + * the expression: rand() */ + +/* Unary operator lexemes */ + +#define UNARY_PLUS ( UNARY | PLUS) +#define UNARY_MINUS ( UNARY | MINUS) +#define FUNCTION ( UNARY | BAREWORD) /* This is a bit of "creative + * interpretation" on the part of the + * parser. A function call is parsed + * into the parse tree according to + * the perspective that the function + * name is a unary operator and its + * argument list, enclosed in parens, + * is its operand. The additional + * requirements not implied generally + * by treatment as a unary operator -- + * for example, the requirement that + * the operand be enclosed in parens -- + * are hard coded in the relevant + * portions of ParseExpr(). We trade + * off the need to include such + * exceptional handling in the code + * against the need we would otherwise + * have for more lexeme categories. */ +#define START ( UNARY | 4) /* This lexeme isn't parsed from the + * expression text at all. It + * represents the start of the + * expression and sits at the root of + * the parse tree where it serves as + * the start/end point of traversals. */ +#define OPEN_PAREN ( UNARY | 5) /* Another bit of creative + * interpretation, where we treat "(" + * as a unary operator with the + * sub-expression between it and its + * matching ")" as its operand. See + * CLOSE_PAREN below. */ +#define NOT ( UNARY | 6) +#define BIT_NOT ( UNARY | 7) + +/* Binary operator lexemes */ + +#define BINARY_PLUS ( BINARY | PLUS) +#define BINARY_MINUS ( BINARY | MINUS) +#define COMMA ( BINARY | 3) /* The "," operator is a low precedence + * binary operator that separates the + * arguments in a function call. The + * additional constraint that this + * operator can only legally appear + * at the right places within a + * function call argument list are + * hard coded within ParseExpr(). */ +#define MULT ( BINARY | 4) +#define DIVIDE ( BINARY | 5) +#define MOD ( BINARY | 6) +#define LESS ( BINARY | 7) +#define GREATER ( BINARY | 8) +#define BIT_AND ( BINARY | 9) +#define BIT_XOR ( BINARY | 10) +#define BIT_OR ( BINARY | 11) +#define QUESTION ( BINARY | 12) /* These two lexemes make up the */ +#define COLON ( BINARY | 13) /* ternary conditional operator, + * $x ? $y : $z . We treat them as + * two binary operators to avoid + * another lexeme category, and + * code the additional constraints + * directly in ParseExpr(). For + * instance, the right operand of + * a "?" operator must be a ":" + * operator. */ +#define LEFT_SHIFT ( BINARY | 14) +#define RIGHT_SHIFT ( BINARY | 15) +#define LEQ ( BINARY | 16) +#define GEQ ( BINARY | 17) +#define EQUAL ( BINARY | 18) +#define NEQ ( BINARY | 19) +#define AND ( BINARY | 20) +#define OR ( BINARY | 21) +#define STREQ ( BINARY | 22) +#define STRNEQ ( BINARY | 23) +#define EXPON ( BINARY | 24) /* Unlike the other binary operators, + * EXPON is right associative and this + * distinction is coded directly in + * ParseExpr(). */ +#define IN_LIST ( BINARY | 25) +#define NOT_IN_LIST ( BINARY | 26) +#define CLOSE_PAREN ( BINARY | 27) /* By categorizing the CLOSE_PAREN + * lexeme as a BINARY operator, the + * normal parsing rules for binary + * operators assure that a close paren + * will not directly follow another + * operator, and the machinery already + * in place to connect operands to + * operators according to precedence + * performs most of the work of + * matching open and close parens for + * us. In the end though, a close + * paren is not really a binary + * operator, and some special coding + * in ParseExpr() make sure we never + * put an actual CLOSE_PAREN node + * in the parse tree. The + * sub-expression between parens + * becomes the single argument of + * the matching OPEN_PAREN unary + * operator. */ +#define END ( BINARY | 28) /* This lexeme represents the end of + * the string being parsed. Treating + * it as a binary operator follows the + * same logic as the CLOSE_PAREN lexeme + * and END pairs with START, in the + * same way that CLOSE_PAREN pairs with + * OPEN_PAREN. */ /* - * Table describing the expression operators. Entries in this table must - * correspond to the definitions of numeric codes for operators just above. + * 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. */ -static int opTableInitialized = 0; /* 0 means not yet initialized. */ - -TCL_DECLARE_MUTEX(opMutex) - -typedef struct OperatorDesc { - char *name; /* Name of the operator. */ - int numOperands; /* Number of operands. 0 if the operator - * requires special handling. */ - int instruction; /* Instruction opcode for the operator. - * Ignored if numOperands is 0. */ -} OperatorDesc; - -static OperatorDesc operatorTable[] = { - {"*", 2, INST_MULT}, - {"/", 2, INST_DIV}, - {"%", 2, INST_MOD}, - {"+", 0}, - {"-", 0}, - {"<<", 2, INST_LSHIFT}, - {">>", 2, INST_RSHIFT}, - {"<", 2, INST_LT}, - {">", 2, INST_GT}, - {"<=", 2, INST_LE}, - {">=", 2, INST_GE}, - {"==", 2, INST_EQ}, - {"!=", 2, INST_NEQ}, - {"&", 2, INST_BITAND}, - {"^", 2, INST_BITXOR}, - {"|", 2, INST_BITOR}, - {"&&", 0}, - {"||", 0}, - {"?", 0}, - {"!", 1, INST_LNOT}, - {"~", 1, INST_BITNOT}, - {"eq", 2, INST_STR_EQ}, - {"ne", 2, INST_STR_NEQ}, - {NULL} +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, "!", "~" */ }; /* - * Hashtable used to map the names of expression operators to the index - * of their OperatorDesc description. + * Here the same information contained in the comments above is stored + * in inverted form, so that given a lexeme, one can quickly look up + * its precedence value. */ -static Tcl_HashTable opHashTable; +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*/ +}; /* - * Declarations for local procedures to this file: + * A table mapping lexemes to bytecode instructions, used by CompileExprTree(). */ -static int CompileCondExpr _ANSI_ARGS_(( - Tcl_Token *exprTokenPtr, ExprInfo *infoPtr, - CompileEnv *envPtr, Tcl_Token **endPtrPtr)); -static int CompileLandOrLorExpr _ANSI_ARGS_(( - Tcl_Token *exprTokenPtr, int opIndex, - ExprInfo *infoPtr, CompileEnv *envPtr, - Tcl_Token **endPtrPtr)); -static int CompileMathFuncCall _ANSI_ARGS_(( - Tcl_Token *exprTokenPtr, CONST char *funcName, - ExprInfo *infoPtr, CompileEnv *envPtr, - Tcl_Token **endPtrPtr)); -static int CompileSubExpr _ANSI_ARGS_(( - Tcl_Token *exprTokenPtr, ExprInfo *infoPtr, - CompileEnv *envPtr)); -static void LogSyntaxError _ANSI_ARGS_((ExprInfo *infoPtr)); +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 expression compiler. + * A table mapping a byte value to the corresponding lexeme for use by + * ParseLexeme(). */ -#ifdef TCL_COMPILE_DEBUG -#define TRACE(exprBytes, exprLength, tokenBytes, tokenLength) \ - if (traceExprComp) { \ - fprintf(stderr, "CompileSubExpr: \"%.*s\", token \"%.*s\"\n", \ - (exprLength), (exprBytes), (tokenLength), (tokenBytes)); \ - } -#else -#define TRACE(exprBytes, exprLength, tokenBytes, tokenLength) -#endif /* TCL_COMPILE_DEBUG */ +static unsigned char Lexeme[] = { + INVALID /* NUL */, INVALID /* SOH */, + INVALID /* STX */, INVALID /* ETX */, + INVALID /* EOT */, INVALID /* ENQ */, + INVALID /* ACK */, INVALID /* BEL */, + INVALID /* BS */, INVALID /* HT */, + INVALID /* LF */, INVALID /* VT */, + INVALID /* FF */, INVALID /* CR */, + INVALID /* SO */, INVALID /* SI */, + INVALID /* DLE */, INVALID /* DC1 */, + INVALID /* DC2 */, INVALID /* DC3 */, + INVALID /* DC4 */, INVALID /* NAK */, + INVALID /* SYN */, INVALID /* ETB */, + INVALID /* CAN */, INVALID /* EM */, + INVALID /* SUB */, INVALID /* ESC */, + INVALID /* FS */, INVALID /* GS */, + INVALID /* RS */, INVALID /* US */, + INVALID /* SPACE */, 0 /* ! or != */, + QUOTED /* " */, INVALID /* # */, + VARIABLE /* $ */, MOD /* % */, + 0 /* & or && */, INVALID /* ' */, + OPEN_PAREN /* ( */, CLOSE_PAREN /* ) */, + 0 /* * or ** */, PLUS /* + */, + COMMA /* , */, MINUS /* - */, + 0 /* . */, DIVIDE /* / */, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0-9 */ + COLON /* : */, INVALID /* ; */, + 0 /* < or << or <= */, + 0 /* == or INVALID */, + 0 /* > or >> or >= */, + QUESTION /* ? */, INVALID /* @ */, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* A-M */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* N-Z */ + SCRIPT /* [ */, INVALID /* \ */, + INVALID /* ] */, BIT_XOR /* ^ */, + INVALID /* _ */, INVALID /* ` */, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* a-m */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* n-z */ + BRACED /* { */, 0 /* | or || */, + INVALID /* } */, BIT_NOT /* ~ */, + INVALID /* DEL */ +}; + +/* + * The JumpList struct is used to create a stack of data needed for the + * TclEmitForwardJump() and TclFixupForwardJump() calls that are performed + * when compiling the short-circuiting operators QUESTION/COLON, AND, and OR. + * Keeping a stack permits the CompileExprTree() routine to be non-recursive. + */ + +typedef struct JumpList { + JumpFixup jump; /* Pass this argument to matching calls of + * TclEmitForwardJump() and + * TclFixupForwardJump(). */ + int depth; /* Remember the currStackDepth of the + * CompileEnv here. */ + int offset; /* Data used to compute jump lengths to pass + * to TclFixupForwardJump() */ + int convert; /* Temporary storage used to compute whether + * numeric conversion will be needed following + * the operator we're compiling. */ + struct JumpList *next; /* Point to next item on the stack */ +} JumpList; + +/* + * Declarations for local functions to this file: + */ + +static void CompileExprTree(Tcl_Interp *interp, OpNode *nodes, + int index, Tcl_Obj *const **litObjvPtr, + Tcl_Obj *const *funcObjv, Tcl_Token *tokenPtr, + CompileEnv *envPtr, int optimize); +static void ConvertTreeToTokens(const char *start, int numBytes, + OpNode *nodes, Tcl_Token *tokenPtr, + Tcl_Parse *parsePtr); +static int ExecConstantExprTree(Tcl_Interp *interp, OpNode *nodes, + int index, Tcl_Obj * const **litObjvPtr); +static int ParseExpr(Tcl_Interp *interp, const char *start, + int numBytes, OpNode **opTreePtr, + Tcl_Obj *litList, Tcl_Obj *funcList, + Tcl_Parse *parsePtr, int parseOnly); +static int ParseLexeme(const char *start, int numBytes, + unsigned char *lexemePtr, Tcl_Obj **literalPtr); + /* *---------------------------------------------------------------------- * - * TclCompileExpr -- + * ParseExpr -- * - * 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. + * 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. + * 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, script, numBytes, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - CONST char *script; /* The source script to compile. */ - int numBytes; /* Number of bytes in script. If < 0, the - * string consists of all bytes up to the - * first null character. */ - 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. */ { - ExprInfo info; - Tcl_Parse parse; - Tcl_HashEntry *hPtr; - int new, i, code; + OpNode *nodes = NULL; /* Pointer to the OpNode storage array where + * we build the parse tree. */ + int nodesAvailable = 64; /* Initial size of the storage array. This + * value establishes a minimum tree memory cost + * of only about 1 kibyte, and is large enough + * for most expressions to parse with no need + * for array growth and reallocation. */ + int nodesUsed = 0; /* Number of OpNodes filled. */ + int scanned = 0; /* Capture number of byte scanned by + * parsing routines. */ + int lastParsed; /* Stores info about what the lexeme parsed + * the previous pass through the parsing loop + * was. If it was an operator, lastParsed is + * the index of the OpNode for that operator. + * If it was not an operator, lastParsed holds + * an OperandTypes value encoding what we + * need to know about it. */ + int incomplete; /* Index of the most recent incomplete tree + * in the OpNode array. Heads a stack of + * incomplete trees linked by p.prev. */ + int complete = OT_EMPTY; /* "Index" of the complete tree (that is, a + * complete subexpression) determined at the + * moment. OT_EMPTY is a nonsense value + * used only to silence compiler warnings. + * During a parse, complete will always hold + * an index or an OperandTypes value pointing + * to an actual leaf at the time the complete + * tree is needed. */ + + /* These variables control generation of the error message. */ + Tcl_Obj *msg = NULL; /* The error message. */ + Tcl_Obj *post = NULL; /* In a few cases, an additional postscript + * for the error message, supplying more + * information after the error msg and + * location have been reported. */ + const char *mark = "_@_"; /* In the portion of the complete error message + * where the error location is reported, this + * "mark" substring is inserted into the + * string being parsed to aid in pinpointing + * the location of the syntax error in the + * expression. */ + int insertMark = 0; /* A boolean controlling whether the "mark" + * should be inserted. */ + const int limit = 25; /* Portions of the error message are + * constructed out of substrings of the + * original expression. In order to keep the + * error message readable, we impose this limit + * on the substring size we extract. */ + + TclParseInit(interp, start, numBytes, parsePtr); + + nodes = (OpNode *) attemptckalloc(nodesAvailable * sizeof(OpNode)); + if (nodes == NULL) { + TclNewLiteralStringObj(msg, "not enough memory to parse expression"); + goto error; + } + + /* Initialize the parse tree with the special "START" node. */ + nodes->lexeme = START; + nodes->precedence = prec[START]; + nodes->mark = MARK_RIGHT; + nodes->constant = 1; + incomplete = lastParsed = nodesUsed; + nodesUsed++; /* - * If this is the first time we've been called, initialize the table - * of expression operators. + * 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. */ - if (numBytes < 0) { - numBytes = (script? strlen(script) : 0); - } - if (!opTableInitialized) { - Tcl_MutexLock(&opMutex); - if (!opTableInitialized) { - Tcl_InitHashTable(&opHashTable, TCL_STRING_KEYS); - for (i = 0; operatorTable[i].name != NULL; i++) { - hPtr = Tcl_CreateHashEntry(&opHashTable, - operatorTable[i].name, &new); - if (new) { - Tcl_SetHashValue(hPtr, (ClientData) i); - } + 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. */ + + /* + * Each pass through this loop adds up to one more OpNode. Allocate + * space for one if required. + */ + + if (nodesUsed >= nodesAvailable) { + int size = nodesUsed * 2; + OpNode *newPtr; + + do { + newPtr = (OpNode *) attemptckrealloc((char *) nodes, + (unsigned int) size * sizeof(OpNode)); + } while ((newPtr == NULL) + && ((size -= (size - nodesUsed) / 2) > nodesUsed)); + if (newPtr == NULL) { + TclNewLiteralStringObj(msg, + "not enough memory to parse expression"); + goto error; } - opTableInitialized = 1; + nodesAvailable = size; + nodes = newPtr; } - Tcl_MutexUnlock(&opMutex); - } + nodePtr = nodes + nodesUsed; + + /* Skip white space between lexemes. */ + scanned = TclParseAllWhiteSpace(start, numBytes); + start += scanned; + numBytes -= scanned; + + scanned = ParseLexeme(start, numBytes, &lexeme, &literal); + + /* Use context to categorize the lexemes that are ambiguous. */ + if ((NODE_TYPE & lexeme) == 0) { + switch (lexeme) { + case INVALID: + msg = Tcl_ObjPrintf( + "invalid character \"%.*s\"", scanned, start); + goto error; + case INCOMPLETE: + msg = Tcl_ObjPrintf( + "incomplete operator \"%.*s\"", scanned, start); + goto error; + case BAREWORD: + + /* + * Most barewords in an expression are a syntax error. + * The exceptions are that when a bareword is followed by + * an open paren, it might be a function call, and when the + * bareword is a legal literal boolean value, we accept that + * as well. + */ + + if (start[scanned+TclParseAllWhiteSpace( + start+scanned, numBytes-scanned)] == '(') { + lexeme = FUNCTION; - /* - * Initialize the structure containing information abvout this - * expression compilation. - */ + /* + * 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. + */ - info.interp = interp; - info.parsePtr = &parse; - info.expr = script; - info.lastChar = (script + numBytes); - info.hasOperators = 0; + Tcl_ListObjAppendElement(NULL, funcList, literal); + } else { + int b; + if (Tcl_GetBooleanFromObj(NULL, literal, &b) == TCL_OK) { + lexeme = BOOLEAN; + } else { + Tcl_DecrRefCount(literal); + msg = Tcl_ObjPrintf( + "invalid bareword \"%.*s%s\"", + (scanned < limit) ? scanned : limit - 3, start, + (scanned < limit) ? "" : "..."); + post = Tcl_ObjPrintf( + "should be \"$%.*s%s\" or \"{%.*s%s}\"", + (scanned < limit) ? scanned : limit - 3, + start, (scanned < limit) ? "" : "...", + (scanned < limit) ? scanned : limit - 3, + start, (scanned < limit) ? "" : "..."); + Tcl_AppendPrintfToObj(post, + " or \"%.*s%s(...)\" or ...", + (scanned < limit) ? scanned : limit - 3, + start, (scanned < limit) ? "" : "..."); + if (start[0] == '0') { + const char *stop; + TclParseNumber(NULL, NULL, NULL, start, scanned, + &stop, TCL_PARSE_NO_WHITESPACE); + + if (isdigit(UCHAR(*stop)) || (stop == start + 1)) { + parsePtr->errorType = TCL_PARSE_BAD_NUMBER; + + switch (start[1]) { + case 'b': + Tcl_AppendToObj(post, + " (invalid binary number?)", -1); + break; + case 'o': + Tcl_AppendToObj(post, + " (invalid octal number?)", -1); + break; + default: + if (isdigit(UCHAR(start[1]))) { + Tcl_AppendToObj(post, + " (invalid octal number?)", -1); + } + 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 */ + + /* Handle lexeme based on its category. */ + switch (NODE_TYPE & lexeme) { + + /* + * Each LEAF results in either a literal getting appended to the + * litList, or a sequence of Tcl_Tokens representing a Tcl word + * getting appended to the parsePtr->tokens. No OpNode is filled + * for this lexeme. + */ + + case LEAF: { + Tcl_Token *tokenPtr; + const char *end = start; + int wordIndex; + int code = TCL_OK; + + /* + * A leaf operand appearing just after something that's not an + * operator is a syntax error. + */ + + if (NotOperator(lastParsed)) { + msg = Tcl_ObjPrintf("missing operator at %s", mark); + scanned = 0; + insertMark = 1; + + /* Free any literal to avoid a memleak. */ + if ((lexeme == NUMBER) || (lexeme == BOOLEAN)) { + Tcl_DecrRefCount(literal); + } + goto error; + } + + 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. + */ + Tcl_ListObjAppendElement(NULL, litList, literal); + complete = lastParsed = OT_LITERAL; + start += scanned; + numBytes -= scanned; + continue; + + default: + break; + } + + /* + * Remaining LEAF cases may involve filling Tcl_Tokens, so + * make room for at least 2 more tokens. + */ + + 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); + + /* + * Handle the quirk that Tcl_ParseVarName reports a successful + * parse even when it gets only a "$" with no variable name. + */ + + tokenPtr = parsePtr->tokenPtr + wordIndex + 1; + if (code == TCL_OK && tokenPtr->type != TCL_TOKEN_VARIABLE) { + TclNewLiteralStringObj(msg, "invalid character \"$\""); + goto error; + } + scanned = tokenPtr->size; + break; + + case SCRIPT: { + Tcl_Parse *nestedPtr = + (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); + + tokenPtr = parsePtr->tokenPtr + parsePtr->numTokens; + tokenPtr->type = TCL_TOKEN_COMMAND; + tokenPtr->start = start; + tokenPtr->numComponents = 0; + + end = start + numBytes; + start++; + while (1) { + code = Tcl_ParseCommand(interp, start, (end - start), 1, + nestedPtr); + if (code != TCL_OK) { + parsePtr->term = nestedPtr->term; + parsePtr->errorType = nestedPtr->errorType; + parsePtr->incomplete = nestedPtr->incomplete; + break; + } + start = (nestedPtr->commandStart + nestedPtr->commandSize); + Tcl_FreeParse(nestedPtr); + if ((nestedPtr->term < end) && (*(nestedPtr->term) == ']') + && !(nestedPtr->incomplete)) { + break; + } + + if (start == end) { + TclNewLiteralStringObj(msg, "missing close-bracket"); + parsePtr->term = tokenPtr->start; + parsePtr->errorType = TCL_PARSE_MISSING_BRACKET; + parsePtr->incomplete = 1; + code = TCL_ERROR; + break; + } + } + TclStackFree(interp, nestedPtr); + end = start; + start = tokenPtr->start; + scanned = end - start; + tokenPtr->size = scanned; + parsePtr->numTokens++; + break; + } + } + if (code != TCL_OK) { + + /* + * Here we handle all the syntax errors generated by + * the Tcl_Token generating parsing routines called in the + * switch just above. If the value of parsePtr->incomplete + * is 1, then the error was an unbalanced '[', '(', '{', + * or '"' and parsePtr->term is pointing to that unbalanced + * character. If the value of parsePtr->incomplete is 0, + * then the error is one of lacking whitespace following a + * quoted word, for example: expr {[an error {foo}bar]}, + * and parsePtr->term points to where the whitespace is + * missing. We reset our values of start and scanned so that + * when our error message is constructed, the location of + * the syntax error is sure to appear in it, even if the + * quoted expression is truncated. + */ + + start = parsePtr->term; + scanned = parsePtr->incomplete; + goto error; + } + + tokenPtr = parsePtr->tokenPtr + wordIndex; + tokenPtr->size = scanned; + tokenPtr->numComponents = parsePtr->numTokens - wordIndex - 1; + if (!parseOnly && ((lexeme == QUOTED) || (lexeme == BRACED))) { + + /* + * When this expression is destined to be compiled, and a + * braced or quoted word within an expression is known at + * compile time (no runtime substitutions in it), we can + * store it as a literal rather than in its tokenized form. + * This is an advantage since the compiled bytecode is going + * to need the argument in Tcl_Obj form eventually, so it's + * just as well to get there now. Another advantage is that + * with this conversion, larger constant expressions might + * be grown and optimized. + * + * On the contrary, if the end goal of this parse is to + * fill a Tcl_Parse for a caller of Tcl_ParseExpr(), then it's + * wasteful to convert to a literal only to convert back again + * later. + */ + + literal = Tcl_NewObj(); + if (TclWordKnownAtCompileTime(tokenPtr, literal)) { + Tcl_ListObjAppendElement(NULL, litList, literal); + complete = lastParsed = OT_LITERAL; + parsePtr->numTokens = wordIndex; + break; + } + Tcl_DecrRefCount(literal); + } + complete = lastParsed = OT_TOKENS; + break; + } /* case LEAF */ + + case UNARY: + + /* + * A unary operator appearing just after something that's not an + * operator is a syntax error -- something trying to be the left + * operand of an operator that doesn't take one. + */ + + if (NotOperator(lastParsed)) { + msg = Tcl_ObjPrintf("missing operator at %s", mark); + scanned = 0; + insertMark = 1; + goto error; + } + + /* Create an OpNode for the unary operator */ + nodePtr->lexeme = lexeme; + nodePtr->precedence = prec[lexeme]; + nodePtr->mark = MARK_RIGHT; + + /* + * A FUNCTION cannot be a constant expression, because Tcl allows + * functions to return variable results with the same arguments; + * for example, rand(). Other unary operators can root a constant + * expression, so long as the argument is a constant expression. + */ + + nodePtr->constant = (lexeme != FUNCTION); + + /* + * This unary operator is a new incomplete tree, so push it + * onto our stack of incomplete trees. Also remember it as + * the last lexeme we parsed. + */ + + nodePtr->p.prev = incomplete; + incomplete = lastParsed = nodesUsed; + nodesUsed++; + break; + + case BINARY: { + OpNode *incompletePtr; + unsigned char precedence = prec[lexeme]; + + /* + * A binary operator appearing just after another operator is a + * syntax error -- one of the two operators is missing an operand. + */ + + if (IsOperator(lastParsed)) { + if ((lexeme == CLOSE_PAREN) + && (nodePtr[-1].lexeme == OPEN_PAREN)) { + if (nodePtr[-2].lexeme == FUNCTION) { + + /* + * Normally, "()" is a syntax error, but as a special + * case accept it as an argument list for a function. + * Treat this as a special LEAF lexeme, and restart + * the parsing loop with zero characters scanned. + * We'll parse the ")" again the next time through, + * but with the OT_EMPTY leaf as the subexpression + * between the parens. + */ + + scanned = 0; + complete = lastParsed = OT_EMPTY; + break; + } + msg = Tcl_ObjPrintf("empty subexpression at %s", mark); + scanned = 0; + insertMark = 1; + goto error; + } + + if (nodePtr[-1].precedence > precedence) { + if (nodePtr[-1].lexeme == OPEN_PAREN) { + TclNewLiteralStringObj(msg, "unbalanced open paren"); + parsePtr->errorType = TCL_PARSE_MISSING_PAREN; + } else if (nodePtr[-1].lexeme == COMMA) { + msg = Tcl_ObjPrintf( + "missing function argument at %s", mark); + scanned = 0; + insertMark = 1; + } else if (nodePtr[-1].lexeme == START) { + TclNewLiteralStringObj(msg, "empty expression"); + } + } else { + if (lexeme == CLOSE_PAREN) { + TclNewLiteralStringObj(msg, "unbalanced close paren"); + } else if ((lexeme == COMMA) + && (nodePtr[-1].lexeme == OPEN_PAREN) + && (nodePtr[-2].lexeme == FUNCTION)) { + msg = Tcl_ObjPrintf( + "missing function argument at %s", mark); + scanned = 0; + insertMark = 1; + } + } + if (msg == NULL) { + msg = Tcl_ObjPrintf("missing operand at %s", mark); + scanned = 0; + insertMark = 1; + } + goto error; + } + + /* + * Here is where the tree comes together. At this point, we + * have a stack of incomplete trees corresponding to + * substrings that are incomplete expressions, followed by + * a complete tree corresponding to a substring that is itself + * a complete expression, followed by the binary operator we have + * just parsed. The incomplete trees can each be completed by + * adding a right operand. + * + * To illustrate with an example, when we parse the expression + * "1+2*3-4" and we reach this point having just parsed the "-" + * operator, we have these incomplete trees: START, "1+", and + * "2*". Next we have the complete subexpression "3". Last is + * the "-" we've just parsed. + * + * The next step is to join our complete tree to an operator. + * The choice is governed by the precedence and associativity + * of the competing operators. If we connect it as the right + * operand of our most recent incomplete tree, we get a new + * complete tree, and we can repeat the process. The while + * loop following repeats this until precedence indicates it + * is time to join the complete tree as the left operand of + * the just parsed binary operator. + * + * Continuing the example, the first pass through the loop + * will join "3" to "2*"; the next pass will join "2*3" to + * "1+". Then we'll exit the loop and join "1+2*3" to "-". + * When we return to parse another lexeme, our stack of + * incomplete trees is START and "1+2*3-". + */ + + while (1) { + incompletePtr = nodes + incomplete; + + if (incompletePtr->precedence < precedence) { + break; + } + + if (incompletePtr->precedence == precedence) { + + /* Right association rules for exponentiation. */ + if (lexeme == EXPON) { + break; + } + + /* + * Special association rules for the conditional operators. + * The "?" and ":" operators have equal precedence, but + * must be linked up in sensible pairs. + */ + + if ((incompletePtr->lexeme == QUESTION) + && (NotOperator(complete) + || (nodes[complete].lexeme != COLON))) { + break; + } + if ((incompletePtr->lexeme == COLON) + && (lexeme == QUESTION)) { + break; + } + } + + /* Some special syntax checks... */ + + /* Parens must balance */ + if ((incompletePtr->lexeme == OPEN_PAREN) + && (lexeme != CLOSE_PAREN)) { + TclNewLiteralStringObj(msg, "unbalanced open paren"); + parsePtr->errorType = TCL_PARSE_MISSING_PAREN; + goto error; + } + + /* Right operand of "?" must be ":" */ + if ((incompletePtr->lexeme == QUESTION) + && (NotOperator(complete) + || (nodes[complete].lexeme != COLON))) { + msg = Tcl_ObjPrintf( + "missing operator \":\" at %s", mark); + scanned = 0; + insertMark = 1; + goto error; + } + + /* Operator ":" may only be right operand of "?" */ + if (IsOperator(complete) + && (nodes[complete].lexeme == COLON) + && (incompletePtr->lexeme != QUESTION)) { + TclNewLiteralStringObj(msg, + "unexpected operator \":\" " + "without preceding \"?\""); + goto error; + } + + /* + * Attach complete tree as right operand of most recent + * incomplete tree. + */ + + incompletePtr->right = complete; + if (IsOperator(complete)) { + nodes[complete].p.parent = incomplete; + incompletePtr->constant = incompletePtr->constant + && nodes[complete].constant; + } else { + incompletePtr->constant = incompletePtr->constant + && (complete == OT_LITERAL); + } + + /* + * The QUESTION/COLON and FUNCTION/OPEN_PAREN combinations each + * make up a single operator. Force them to agree whether they + * have a constant expression. + */ + + if ((incompletePtr->lexeme == QUESTION) + || (incompletePtr->lexeme == FUNCTION)) { + nodes[complete].constant = incompletePtr->constant; + } + + if (incompletePtr->lexeme == START) { + + /* + * Completing the START tree indicates we're done. + * Transfer the parse tree to the caller and return. + */ + + *opTreePtr = nodes; + return TCL_OK; + } + + /* + * With a right operand attached, last incomplete tree has + * become the complete tree. Pop it from the incomplete + * tree stack. + */ + + complete = incomplete; + incomplete = incompletePtr->p.prev; + + /* CLOSE_PAREN can only close one OPEN_PAREN. */ + if (incompletePtr->lexeme == OPEN_PAREN) { + break; + } + } + + /* More syntax checks... */ + + /* Parens must balance. */ + if (lexeme == CLOSE_PAREN) { + if (incompletePtr->lexeme != OPEN_PAREN) { + TclNewLiteralStringObj(msg, "unbalanced close paren"); + goto error; + } + } + + /* Commas must appear only in function argument lists. */ + if (lexeme == COMMA) { + if ((incompletePtr->lexeme != OPEN_PAREN) + || (incompletePtr[-1].lexeme != FUNCTION)) { + TclNewLiteralStringObj(msg, + "unexpected \",\" outside function argument list"); + goto error; + } + } + + /* Operator ":" may only be right operand of "?" */ + if (IsOperator(complete) && (nodes[complete].lexeme == COLON)) { + TclNewLiteralStringObj(msg, + "unexpected operator \":\" without preceding \"?\""); + goto error; + } + + /* Create no node for a CLOSE_PAREN lexeme. */ + if (lexeme == CLOSE_PAREN) { + break; + } + + /* Link complete tree as left operand of new node. */ + nodePtr->lexeme = lexeme; + nodePtr->precedence = precedence; + nodePtr->mark = MARK_LEFT; + nodePtr->left = complete; + + /* + * The COMMA operator cannot be optimized, since the function + * needs all of its arguments, and optimization would reduce + * the number. Other binary operators root constant expressions + * when both arguments are constant expressions. + */ + + nodePtr->constant = (lexeme != COMMA); + + if (IsOperator(complete)) { + nodes[complete].p.parent = nodesUsed; + nodePtr->constant = nodePtr->constant + && nodes[complete].constant; + } else { + nodePtr->constant = nodePtr->constant + && (complete == OT_LITERAL); + } + + /* + * With a left operand attached and a right operand missing, + * the just-parsed binary operator is root of a new incomplete + * tree. Push it onto the stack of incomplete trees. + */ + + nodePtr->p.prev = incomplete; + incomplete = lastParsed = nodesUsed; + nodesUsed++; + break; + } /* case BINARY */ + } /* lexeme handler */ + + /* Advance past the just-parsed lexeme */ + start += scanned; + numBytes -= scanned; + } /* main parsing loop */ + + error: /* - * Parse the expression then compile it. + * 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. */ - code = Tcl_ParseExpr(interp, script, numBytes, &parse); - if (code != TCL_OK) { - goto done; + if (parsePtr->errorType == TCL_PARSE_SUCCESS) { + parsePtr->errorType = TCL_PARSE_SYNTAX; } -#ifdef TCL_TIP280 - /* TIP #280 : Track Lines within the expression */ - TclAdvanceLines (&envPtr->line, script, parse.tokenPtr->start); -#endif - - code = CompileSubExpr(parse.tokenPtr, &info, envPtr); - if (code != TCL_OK) { - Tcl_FreeParse(&parse); - goto done; + /* Free any partial parse tree we've built. */ + if (nodes != NULL) { + ckfree((char*) nodes); } - - if (!info.hasOperators) { + + if (interp == NULL) { + + /* Nowhere to report an error message, so just free it */ + if (msg) { + Tcl_DecrRefCount(msg); + } + } else { + /* - * 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. + * Construct the complete error message. Start with the simple + * error message, pulled from the interp result if necessary... */ - - TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); + + if (msg == NULL) { + msg = Tcl_GetObjResult(interp); + } + + /* + * Add a detailed quote from the bad expression, displaying and + * sometimes marking the precise location of the syntax error. + */ + + Tcl_AppendPrintfToObj(msg, "\nin expression \"%s%.*s%.*s%s%s%.*s%s\"", + ((start - limit) < parsePtr->string) ? "" : "...", + ((start - limit) < parsePtr->string) + ? (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) ? "" : "..."); + + /* Next, append any postscript message. */ + if (post != NULL) { + Tcl_AppendToObj(msg, ";\n", -1); + Tcl_AppendObjToObj(msg, post); + Tcl_DecrRefCount(post); + } + Tcl_SetObjResult(interp, msg); + + /* Finally, place context information in the errorInfo. */ + numBytes = parsePtr->end - parsePtr->string; + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (parsing expression \"%.*s%s\")", + (numBytes < limit) ? numBytes : limit - 3, + parsePtr->string, (numBytes < limit) ? "" : "...")); } - Tcl_FreeParse(&parse); - done: - return code; + return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * TclFinalizeCompilation -- + * ConvertTreeToTokens -- * - * Clean up the compilation environment so it can later be - * properly reinitialized. This procedure is called by Tcl_Finalize(). + * Given a string, the numBytes bytes starting at start, and an OpNode + * tree and Tcl_Token array created by passing that same string to + * ParseExpr(), this function writes into *parsePtr the sequence of + * Tcl_Tokens needed so to satisfy the historical interface provided + * by Tcl_ParseExpr(). Note that this routine exists only for the sake + * of the public Tcl_ParseExpr() routine. It is not used by Tcl itself + * at all. * * Results: * None. * * Side effects: - * Cleans up the compilation environment. At the moment, just the - * table of expression operators is freed. + * The Tcl_Parse *parsePtr is filled with Tcl_Tokens representing the + * parsed expression. * *---------------------------------------------------------------------- */ -void -TclFinalizeCompilation() +static void +ConvertTreeToTokens( + const char *start, + int numBytes, + OpNode *nodes, + Tcl_Token *tokenPtr, + Tcl_Parse *parsePtr) { - Tcl_MutexLock(&opMutex); - if (opTableInitialized) { - Tcl_DeleteHashTable(&opHashTable); - opTableInitialized = 0; + int subExprTokenIdx = 0; + OpNode *nodePtr = nodes; + int next = nodePtr->right; + + while (1) { + Tcl_Token *subExprTokenPtr; + int scanned, parentIdx; + unsigned char lexeme; + + /* + * Advance the mark so the next exit from this node won't retrace + * steps over ground already covered. + */ + + nodePtr->mark++; + + /* Handle next child node or leaf */ + switch (next) { + case OT_EMPTY: + + /* No tokens and no characters for the OT_EMPTY leaf. */ + break; + + case OT_LITERAL: + + /* Skip any white space that comes before the literal */ + scanned = TclParseAllWhiteSpace(start, numBytes); + start +=scanned; + numBytes -= scanned; + + /* Reparse the literal to get pointers into source string */ + scanned = ParseLexeme(start, numBytes, &lexeme, NULL); + + 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. + */ + + scanned = ParseLexeme(start, numBytes, &lexeme, NULL); + + switch(nodePtr->lexeme) { + case OPEN_PAREN: + case COMMA: + case COLON: + + /* No tokens for these lexemes -> nothing to do. */ + break; + + default: + + /* + * Record in the TCL_TOKEN_OPERATOR token the pointers into + * the string marking where the operator is. + */ + + subExprTokenPtr = parsePtr->tokenPtr + subExprTokenIdx; + subExprTokenPtr[1].start = start; + subExprTokenPtr[1].size = scanned; + break; + } + + start +=scanned; + numBytes -= scanned; + break; + + case MARK_PARENT: + switch (nodePtr->lexeme) { + case START: + + /* When we get back to the START node, we're done. */ + return; + + case COMMA: + case COLON: + + /* No tokens for these lexemes -> nothing to do. */ + break; + + case OPEN_PAREN: + + /* Skip past matching close paren. */ + scanned = TclParseAllWhiteSpace(start, numBytes); + start +=scanned; + numBytes -= scanned; + scanned = ParseLexeme(start, numBytes, &lexeme, NULL); + start +=scanned; + numBytes -= scanned; + break; + + default: { + + /* + * Before we leave this node/operator/subexpression for the + * last time, finish up its tokens.... + * + * Our current position scanning the string is where the + * substring for the subexpression ends. + */ + + subExprTokenPtr = parsePtr->tokenPtr + subExprTokenIdx; + subExprTokenPtr->size = start - subExprTokenPtr->start; + + /* + * All the Tcl_Tokens allocated and filled belong to + * this subexpresion. The first token is the leading + * TCL_TOKEN_SUB_EXPR token, and all the rest (one fewer) + * are its components. + */ + + subExprTokenPtr->numComponents = + (parsePtr->numTokens - subExprTokenIdx) - 1; + + /* + * Finally, as we return up the tree to our parent, pop the + * parent subexpression off our subexpression stack, and + * fill in the zero numComponents for the operator Tcl_Token. + */ + + parentIdx = subExprTokenPtr[1].numComponents; + subExprTokenPtr[1].numComponents = 0; + subExprTokenIdx = parentIdx; + break; + } + } + + /* Since we're returning to parent, skip child handling code. */ + nodePtr = nodes + nodePtr->p.parent; + goto router; + } } - Tcl_MutexUnlock(&opMutex); } /* *---------------------------------------------------------------------- * - * CompileSubExpr -- + * Tcl_ParseExpr -- * - * Given a pointer to a TCL_TOKEN_SUB_EXPR token describing a - * subexpression, this procedure emits instructions to evaluate the - * subexpression at runtime. + * 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. + * 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 subexpression. + * If there is insufficient space in parsePtr to hold all the information + * about the expression, then additional space is malloc-ed. If the + * function returns TCL_OK then the caller must eventually invoke + * Tcl_FreeParse to release any additional space that was allocated. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ParseExpr( + Tcl_Interp *interp, /* Used for error reporting. */ + const char *start, /* Start of source string to parse. */ + int numBytes, /* Number of bytes in string. If < 0, the + * string consists of all bytes up to the + * first null character. */ + Tcl_Parse *parsePtr) /* Structure to fill with information about + * the parsed expression; any previous + * information in the structure is ignored. */ +{ + int code; + OpNode *opTree = NULL; /* Will point to the tree of operators */ + Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals */ + Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names*/ + Tcl_Parse *exprParsePtr = + (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); + /* Holds the Tcl_Tokens of substitutions */ + + if (numBytes < 0) { + numBytes = (start ? strlen(start) : 0); + } + + code = ParseExpr(interp, start, numBytes, &opTree, litList, + funcList, exprParsePtr, 1 /* parseOnly */); + Tcl_DecrRefCount(funcList); + Tcl_DecrRefCount(litList); + + TclParseInit(interp, start, numBytes, parsePtr); + if (code == TCL_OK) { + ConvertTreeToTokens(start, numBytes, + opTree, exprParsePtr->tokenPtr, parsePtr); + } else { + parsePtr->term = exprParsePtr->term; + parsePtr->errorType = exprParsePtr->errorType; + } + + Tcl_FreeParse(exprParsePtr); + TclStackFree(interp, exprParsePtr); + ckfree((char *) opTree); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * ParseLexeme -- + * + * Parse a single lexeme from the start of a string, scanning no more + * than numBytes bytes. + * + * Results: + * Returns the number of bytes scanned to produce the lexeme. + * + * Side effects: + * Code identifying lexeme parsed is writen to *lexemePtr. * *---------------------------------------------------------------------- */ static int -CompileSubExpr(exprTokenPtr, infoPtr, envPtr) - Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token - * to compile. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - 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. */ { - Tcl_Interp *interp = infoPtr->interp; - Tcl_Token *tokenPtr, *endPtr = NULL; /* silence gcc 4 warning */ - Tcl_Token *afterSubexprPtr; - OperatorDesc *opDescPtr; - Tcl_HashEntry *hPtr; - CONST char *operator; - Tcl_DString opBuf; - int objIndex, opIndex, length, code; - char buffer[TCL_UTF_MAX]; - - if (exprTokenPtr->type != TCL_TOKEN_SUB_EXPR) { - panic("CompileSubExpr: token type %d not TCL_TOKEN_SUB_EXPR\n", - exprTokenPtr->type); + const char *end; + int scanned; + Tcl_UniChar ch; + Tcl_Obj *literal = NULL; + unsigned char byte; + + if (numBytes == 0) { + *lexemePtr = END; + return 0; } - code = TCL_OK; + byte = (unsigned char)(*start); + if (byte < sizeof(Lexeme) && Lexeme[byte] != 0) { + *lexemePtr = Lexeme[byte]; + return 1; + } + switch (byte) { + case '*': + if ((numBytes > 1) && (start[1] == '*')) { + *lexemePtr = EXPON; + return 2; + } + *lexemePtr = MULT; + return 1; - /* - * Switch on the type of the first token after the subexpression token. - * After processing it, advance tokenPtr to point just after the - * subexpression's last token. - */ - - tokenPtr = exprTokenPtr+1; - TRACE(exprTokenPtr->start, exprTokenPtr->size, - tokenPtr->start, tokenPtr->size); - switch (tokenPtr->type) { - case TCL_TOKEN_WORD: - code = TclCompileTokens(interp, tokenPtr+1, - tokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr += (tokenPtr->numComponents + 1); - break; - - case TCL_TOKEN_TEXT: - if (tokenPtr->size > 0) { - objIndex = TclRegisterNewLiteral(envPtr, tokenPtr->start, - tokenPtr->size); - } else { - objIndex = TclRegisterNewLiteral(envPtr, "", 0); - } - TclEmitPush(objIndex, envPtr); - tokenPtr += 1; - break; - - case TCL_TOKEN_BS: - length = TclParseBackslash(tokenPtr->start, tokenPtr->size, - (int *) NULL, buffer); - if (length > 0) { - objIndex = TclRegisterNewLiteral(envPtr, buffer, length); - } else { - objIndex = TclRegisterNewLiteral(envPtr, "", 0); - } - TclEmitPush(objIndex, envPtr); - tokenPtr += 1; - break; - - case TCL_TOKEN_COMMAND: - code = TclCompileScript(interp, tokenPtr->start+1, - tokenPtr->size-2, /*nested*/ 0, envPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr += 1; - break; - - case TCL_TOKEN_VARIABLE: - code = TclCompileTokens(interp, tokenPtr, 1, envPtr); - if (code != TCL_OK) { - goto done; + case '=': + if ((numBytes > 1) && (start[1] == '=')) { + *lexemePtr = EQUAL; + return 2; + } + *lexemePtr = INCOMPLETE; + return 1; + + case '!': + if ((numBytes > 1) && (start[1] == '=')) { + *lexemePtr = NEQ; + return 2; + } + *lexemePtr = NOT; + return 1; + + case '&': + if ((numBytes > 1) && (start[1] == '&')) { + *lexemePtr = AND; + return 2; + } + *lexemePtr = BIT_AND; + return 1; + + case '|': + if ((numBytes > 1) && (start[1] == '|')) { + *lexemePtr = OR; + return 2; + } + *lexemePtr = BIT_OR; + return 1; + + case '<': + if (numBytes > 1) { + switch (start[1]) { + case '<': + *lexemePtr = LEFT_SHIFT; + return 2; + case '=': + *lexemePtr = LEQ; + return 2; } - tokenPtr += (tokenPtr->numComponents + 1); - break; - - case TCL_TOKEN_SUB_EXPR: - code = CompileSubExpr(tokenPtr, infoPtr, envPtr); - if (code != TCL_OK) { - goto done; + } + *lexemePtr = LESS; + return 1; + + case '>': + if (numBytes > 1) { + switch (start[1]) { + case '>': + *lexemePtr = RIGHT_SHIFT; + return 2; + case '=': + *lexemePtr = GEQ; + return 2; } - tokenPtr += (tokenPtr->numComponents + 1); - break; - - case TCL_TOKEN_OPERATOR: + } + *lexemePtr = GREATER; + return 1; + + case 'i': + if ((numBytes > 1) && (start[1] == 'n') + && ((numBytes == 2) || !isalpha(UCHAR(start[2])))) { + /* - * Look up the operator. If the operator isn't found, treat it - * as a math function. + * Must make this check so we can tell the difference between + * the "in" operator and the "int" function name and the + * "infinity" numeric value. */ - Tcl_DStringInit(&opBuf); - operator = Tcl_DStringAppend(&opBuf, - tokenPtr->start, tokenPtr->size); - hPtr = Tcl_FindHashEntry(&opHashTable, operator); - if (hPtr == NULL) { - code = CompileMathFuncCall(exprTokenPtr, operator, infoPtr, - envPtr, &endPtr); - Tcl_DStringFree(&opBuf); - if (code != TCL_OK) { - goto done; - } - tokenPtr = endPtr; - break; + + *lexemePtr = IN_LIST; + return 2; + } + break; + + case 'e': + if ((numBytes > 1) && (start[1] == 'q') + && ((numBytes == 2) || !isalpha(UCHAR(start[2])))) { + *lexemePtr = STREQ; + return 2; + } + break; + + case 'n': + if ((numBytes > 1) && ((numBytes == 2) || !isalpha(UCHAR(start[2])))) { + switch (start[1]) { + case 'e': + *lexemePtr = STRNEQ; + return 2; + case 'i': + *lexemePtr = NOT_IN_LIST; + return 2; + } + } + } + + literal = Tcl_NewObj(); + if (TclParseNumber(NULL, literal, NULL, start, numBytes, &end, + TCL_PARSE_NO_WHITESPACE) == TCL_OK) { + 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); } - Tcl_DStringFree(&opBuf); - opIndex = (int) Tcl_GetHashValue(hPtr); - opDescPtr = &(operatorTable[opIndex]); + return (end-start); + } else { + unsigned char lexeme; /* - * If the operator is "normal", compile it using information - * from the operator table. + * 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 (opDescPtr->numOperands > 0) { - tokenPtr++; - code = CompileSubExpr(tokenPtr, infoPtr, envPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr += (tokenPtr->numComponents + 1); - - if (opDescPtr->numOperands == 2) { - code = CompileSubExpr(tokenPtr, infoPtr, envPtr); - if (code != TCL_OK) { - goto done; + 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; } - tokenPtr += (tokenPtr->numComponents + 1); } - TclEmitOpcode(opDescPtr->instruction, envPtr); - infoPtr->hasOperators = 1; - break; } - + 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; + } /* - * The operator requires special treatment, and is either - * "+" or "-", or one of "&&", "||" or "?". + * Otherwise, fall through and parse the whole as a bareword. */ - - switch (opIndex) { - case OP_PLUS: - case OP_MINUS: - tokenPtr++; - code = CompileSubExpr(tokenPtr, infoPtr, envPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr += (tokenPtr->numComponents + 1); - - /* - * Check whether the "+" or "-" is unary. - */ - - afterSubexprPtr = exprTokenPtr - + exprTokenPtr->numComponents+1; - if (tokenPtr == afterSubexprPtr) { - TclEmitOpcode(((opIndex==OP_PLUS)? - INST_UPLUS : INST_UMINUS), - envPtr); - break; - } - - /* - * The "+" or "-" is binary. - */ - - code = CompileSubExpr(tokenPtr, infoPtr, envPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr += (tokenPtr->numComponents + 1); - TclEmitOpcode(((opIndex==OP_PLUS)? INST_ADD : INST_SUB), - envPtr); - break; - - case OP_LAND: - case OP_LOR: - code = CompileLandOrLorExpr(exprTokenPtr, opIndex, - infoPtr, envPtr, &endPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr = endPtr; - break; - - case OP_QUESTY: - code = CompileCondExpr(exprTokenPtr, infoPtr, - envPtr, &endPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr = endPtr; - break; - - default: - panic("CompileSubExpr: unexpected operator %d requiring special treatment\n", - opIndex); - } /* end switch on operator requiring special treatment */ - infoPtr->hasOperators = 1; - break; - - default: - panic("CompileSubExpr: unexpected token type %d\n", - tokenPtr->type); + } } - /* - * Verify that the subexpression token had the required number of - * subtokens: that we've advanced tokenPtr just beyond the - * subexpression's last token. For example, a "*" subexpression must - * contain the tokens for exactly two operands. - */ - - if (tokenPtr != (exprTokenPtr + exprTokenPtr->numComponents+1)) { - LogSyntaxError(infoPtr); - code = TCL_ERROR; + 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); } - - done: - return code; + 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]; + 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); } /* *---------------------------------------------------------------------- * - * CompileLandOrLorExpr -- + * TclCompileExpr -- * - * This procedure compiles a Tcl logical and ("&&") or logical or - * ("||") subexpression. + * 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_OK is returned, a pointer to the token just after - * the last one in the subexpression is stored at the address in - * endPtrPtr. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. + * None. * * Side effects: * Adds instructions to envPtr to evaluate the expression at runtime. @@ -580,387 +2022,680 @@ CompileSubExpr(exprTokenPtr, infoPtr, envPtr) *---------------------------------------------------------------------- */ -static int -CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, endPtrPtr) - Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token - * containing the "&&" or "||" operator. */ - int opIndex; /* A code describing the expression - * operator: either OP_LAND or OP_LOR. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - CompileEnv *envPtr; /* Holds resulting instructions. */ - Tcl_Token **endPtrPtr; /* If successful, a pointer to the token - * just after the last token in the - * subexpression is stored here. */ +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 */ { - JumpFixup shortCircuitFixup; /* Used to fix up the short circuit jump - * after the first subexpression. */ - JumpFixup lhsTrueFixup, lhsEndFixup; - /* Used to fix up jumps used to convert the - * first operand to 0 or 1. */ - Tcl_Token *tokenPtr; - int dist, code; - int savedStackDepth = envPtr->currStackDepth; + OpNode *opTree = NULL; /* Will point to the tree of operators */ + Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals */ + Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names*/ + Tcl_Parse *parsePtr = + (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); + /* Holds the Tcl_Tokens of substitutions */ + + int code = ParseExpr(interp, script, numBytes, &opTree, litList, + funcList, parsePtr, 0 /* parseOnly */); + + if (code == TCL_OK) { + + /* Valid parse; compile the tree. */ + int objc; + Tcl_Obj *const *litObjv; + Tcl_Obj **funcObjv; + + /* TIP #280 : Track Lines within the expression */ + TclAdvanceLines(&envPtr->line, script, + script + TclParseAllWhiteSpace(script, numBytes)); + + TclListObjGetElements(NULL, litList, &objc, (Tcl_Obj ***)&litObjv); + TclListObjGetElements(NULL, funcList, &objc, &funcObjv); + CompileExprTree(interp, opTree, 0, &litObjv, funcObjv, + parsePtr->tokenPtr, envPtr, optimize); + } else { + TclCompileSyntaxError(interp, envPtr); + } - /* - * Emit code for the first operand. - */ + Tcl_FreeParse(parsePtr); + TclStackFree(interp, parsePtr); + Tcl_DecrRefCount(funcList); + Tcl_DecrRefCount(litList); + ckfree((char *) opTree); +} + +/* + *---------------------------------------------------------------------- + * + * ExecConstantExprTree -- + * Compiles and executes bytecode for the subexpression tree at index + * in the nodes array. This subexpression must be constant, made up + * of only constant operators (not functions) and literals. + * + * Results: + * A standard Tcl return code and result left in interp. + * + * Side effects: + * Consumes subtree of nodes rooted at index. Advances the pointer + * *litObjvPtr. + * + *---------------------------------------------------------------------- + */ - tokenPtr = exprTokenPtr+2; - code = CompileSubExpr(tokenPtr, infoPtr, envPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr += (tokenPtr->numComponents + 1); +static int +ExecConstantExprTree( + Tcl_Interp *interp, + OpNode *nodes, + int index, + Tcl_Obj *const **litObjvPtr) +{ + CompileEnv *envPtr; + ByteCode *byteCodePtr; + int code; + Tcl_Obj *byteCodeObj = Tcl_NewObj(); /* - * Convert the first operand to the result that Tcl requires: - * "0" or "1". Eventually we'll use a new instruction for this. + * 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. */ - - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &lhsTrueFixup); - TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &lhsEndFixup); - dist = (envPtr->codeNext - envPtr->codeStart) - lhsTrueFixup.codeOffset; - if (TclFixupForwardJump(envPtr, &lhsTrueFixup, dist, 127)) { - badDist: - panic("CompileLandOrLorExpr: bad jump distance %d\n", dist); - } - envPtr->currStackDepth = savedStackDepth; - TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr); - dist = (envPtr->codeNext - envPtr->codeStart) - lhsEndFixup.codeOffset; - if (TclFixupForwardJump(envPtr, &lhsEndFixup, dist, 127)) { - goto badDist; - } - /* - * Emit the "short circuit" jump around the rest of the expression. - * Duplicate the "0" or "1" on top of the stack first to keep the - * jump from consuming it. - */ + envPtr = (CompileEnv *) TclStackAlloc(interp, sizeof(CompileEnv)); + TclInitCompileEnv(interp, envPtr, NULL, 0, NULL, 0); + CompileExprTree(interp, nodes, index, litObjvPtr, NULL, NULL, envPtr, + 0 /* optimize */); + TclEmitOpcode(INST_DONE, envPtr); + Tcl_IncrRefCount(byteCodeObj); + TclInitByteCodeObj(byteCodeObj, envPtr); + TclFreeCompileEnv(envPtr); + TclStackFree(interp, envPtr); + byteCodePtr = (ByteCode *) byteCodeObj->internalRep.otherValuePtr; + code = TclExecuteByteCode(interp, byteCodePtr); + Tcl_DecrRefCount(byteCodeObj); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * CompileExprTree -- + * Compiles and writes to envPtr instructions for the subexpression + * tree at index in the nodes array. (*litObjvPtr) must point to the + * proper location in a corresponding literals list. Likewise, when + * non-NULL, funcObjv and tokenPtr must point into matching arrays of + * function names and Tcl_Token's derived from earlier call to + * ParseExpr(). When optimize is true, any constant subexpressions + * will be precomputed. + * + * Results: + * None. + * + * Side effects: + * Adds instructions to envPtr to evaluate the expression at runtime. + * Consumes subtree of nodes rooted at index. Advances the pointer + * *litObjvPtr. + * + *---------------------------------------------------------------------- + */ - TclEmitOpcode(INST_DUP, envPtr); - TclEmitForwardJump(envPtr, - ((opIndex==OP_LAND)? TCL_FALSE_JUMP : TCL_TRUE_JUMP), - &shortCircuitFixup); +static void +CompileExprTree( + Tcl_Interp *interp, + OpNode *nodes, + int index, + Tcl_Obj *const **litObjvPtr, + Tcl_Obj *const *funcObjv, + Tcl_Token *tokenPtr, + CompileEnv *envPtr, + int optimize) +{ + OpNode *nodePtr = nodes + index; + OpNode *rootPtr = nodePtr; + int numWords = 0; + JumpList *jumpPtr = NULL; + int convert = 1; + + while (1) { + int next; + JumpList *freePtr, *newJump; + + if (nodePtr->mark == MARK_LEFT) { + next = nodePtr->left; + + switch (nodePtr->lexeme) { + case QUESTION: + newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; + newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; + jumpPtr->depth = envPtr->currStackDepth; + convert = 1; + break; + case AND: + case OR: + newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; + newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; + newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; + jumpPtr->depth = envPtr->currStackDepth; + break; + } + } else if (nodePtr->mark == MARK_RIGHT) { + next = nodePtr->right; + + switch (nodePtr->lexeme) { + case FUNCTION: { + Tcl_DString cmdName; + const char *p; + int length; + + Tcl_DStringInit(&cmdName); + Tcl_DStringAppend(&cmdName, "tcl::mathfunc::", -1); + p = TclGetStringFromObj(*funcObjv, &length); + funcObjv++; + Tcl_DStringAppend(&cmdName, p, length); + TclEmitPush(TclRegisterNewNSLiteral(envPtr, + Tcl_DStringValue(&cmdName), + Tcl_DStringLength(&cmdName)), envPtr); + Tcl_DStringFree(&cmdName); + + /* + * Start a count of the number of words in this function + * command invocation. In case there's already a count + * in progress (nested functions), save it in our unused + * "left" field for restoring later. + */ + + nodePtr->left = numWords; + numWords = 2; /* Command plus one argument */ + break; + } + case QUESTION: + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &(jumpPtr->jump)); + break; + case COLON: + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, + &(jumpPtr->next->jump)); + envPtr->currStackDepth = jumpPtr->depth; + jumpPtr->offset = (envPtr->codeNext - envPtr->codeStart); + jumpPtr->convert = convert; + convert = 1; + break; + case AND: + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &(jumpPtr->jump)); + break; + case OR: + TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &(jumpPtr->jump)); + break; + } + } else { + switch (nodePtr->lexeme) { + case START: + case QUESTION: + if (convert && (nodePtr == rootPtr)) { + TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); + } + break; + case OPEN_PAREN: - /* - * Emit code for the second operand. - */ + /* do nothing */ + break; + case FUNCTION: - code = CompileSubExpr(tokenPtr, infoPtr, envPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr += (tokenPtr->numComponents + 1); + /* + * Use the numWords count we've kept to invoke the + * function command with the correct number of arguments. + */ - /* - * Emit a "logical and" or "logical or" instruction. This does not try - * to "short- circuit" the evaluation of both operands, but instead - * ensures that we either have a "1" or a "0" result. - */ + if (numWords < 255) { + TclEmitInstInt1(INST_INVOKE_STK1, numWords, envPtr); + } else { + TclEmitInstInt4(INST_INVOKE_STK4, numWords, envPtr); + } - TclEmitOpcode(((opIndex==OP_LAND)? INST_LAND : INST_LOR), envPtr); + /* Restore any saved numWords value. */ + numWords = nodePtr->left; + convert = 1; + break; + case COMMA: - /* - * Now that we know the target of the forward jump, update it with the - * correct distance. - */ + /* Each comma implies another function argument. */ + numWords++; + break; + case COLON: + if (TclFixupForwardJump(envPtr, &(jumpPtr->next->jump), + (envPtr->codeNext - envPtr->codeStart) + - jumpPtr->next->jump.codeOffset, 127)) { + jumpPtr->offset += 3; + } + TclFixupForwardJump(envPtr, &(jumpPtr->jump), + jumpPtr->offset - jumpPtr->jump.codeOffset, 127); + convert |= jumpPtr->convert; + envPtr->currStackDepth = jumpPtr->depth + 1; + freePtr = jumpPtr; + jumpPtr = jumpPtr->next; + TclStackFree(interp, freePtr); + freePtr = jumpPtr; + jumpPtr = jumpPtr->next; + TclStackFree(interp, freePtr); + break; + case AND: + case OR: + TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) + ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, + &(jumpPtr->next->jump)); + TclEmitPush(TclRegisterNewLiteral(envPtr, + (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, + &(jumpPtr->next->next->jump)); + TclFixupForwardJumpToHere(envPtr, &(jumpPtr->next->jump), 127); + if (TclFixupForwardJumpToHere(envPtr, &(jumpPtr->jump), 127)) { + jumpPtr->next->next->jump.codeOffset += 3; + } + TclEmitPush(TclRegisterNewLiteral(envPtr, + (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr); + TclFixupForwardJumpToHere(envPtr, &(jumpPtr->next->next->jump), + 127); + convert = 0; + envPtr->currStackDepth = jumpPtr->depth + 1; + freePtr = jumpPtr; + jumpPtr = jumpPtr->next; + TclStackFree(interp, freePtr); + freePtr = jumpPtr; + jumpPtr = jumpPtr->next; + TclStackFree(interp, freePtr); + freePtr = jumpPtr; + jumpPtr = jumpPtr->next; + TclStackFree(interp, freePtr); + break; + default: + TclEmitOpcode(instruction[nodePtr->lexeme], envPtr); + convert = 0; + break; + } + if (nodePtr == rootPtr) { - dist = (envPtr->codeNext - envPtr->codeStart) - - shortCircuitFixup.codeOffset; - TclFixupForwardJump(envPtr, &shortCircuitFixup, dist, 127); - *endPtrPtr = tokenPtr; + /* We're done */ + return; + } + nodePtr = nodes + nodePtr->p.parent; + continue; + } - done: - envPtr->currStackDepth = savedStackDepth + 1; - return code; + nodePtr->mark++; + switch (next) { + case OT_EMPTY: + numWords = 1; /* No arguments, so just the command */ + break; + case OT_LITERAL: { + Tcl_Obj *const *litObjv = *litObjvPtr; + Tcl_Obj *literal = *litObjv; + + if (optimize) { + int length, index; + const char *bytes = TclGetStringFromObj(literal, &length); + LiteralEntry *lePtr; + Tcl_Obj *objPtr; + + index = TclRegisterNewLiteral(envPtr, bytes, length); + lePtr = envPtr->literalArrayPtr + index; + objPtr = lePtr->objPtr; + 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; + } + case OT_TOKENS: + TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, + envPtr); + tokenPtr += tokenPtr->numComponents + 1; + break; + default: + if (optimize && nodes[next].constant) { + Tcl_InterpState save = Tcl_SaveInterpState(interp, TCL_OK); + if (ExecConstantExprTree(interp, nodes, next, litObjvPtr) + == TCL_OK) { + TclEmitPush(TclAddLiteralObj(envPtr, + Tcl_GetObjResult(interp), NULL), envPtr); + } else { + TclCompileSyntaxError(interp, envPtr); + } + Tcl_RestoreInterpState(interp, save); + convert = 0; + } else { + nodePtr = nodes + next; + } + } + } } /* *---------------------------------------------------------------------- * - * CompileCondExpr -- - * - * This procedure compiles a Tcl conditional expression: - * condExpr ::= lorExpr ['?' condExpr ':' condExpr] + * TclSingleOpCmd -- + * Implements the commands: ~, !, <<, >>, %, !=, ne, in, ni + * in the ::tcl::mathop namespace. These commands have no + * extension to arbitrary arguments; they accept only exactly one + * or exactly two arguments as suitable for the operator. * * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_OK is returned, a pointer to the token just after - * the last one in the subexpression is stored at the address in - * endPtrPtr. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. + * 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 -CompileCondExpr(exprTokenPtr, infoPtr, envPtr, endPtrPtr) - Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token - * containing the "?" operator. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - CompileEnv *envPtr; /* Holds resulting instructions. */ - Tcl_Token **endPtrPtr; /* If successful, a pointer to the token - * just after the last token in the - * subexpression is stored here. */ +int +TclSingleOpCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) { - JumpFixup jumpAroundThenFixup, jumpAroundElseFixup; - /* Used to update or replace one-byte jumps - * around the then and else expressions when - * their target PCs are determined. */ - Tcl_Token *tokenPtr; - int elseCodeOffset, dist, code; - int savedStackDepth = envPtr->currStackDepth; - - /* - * Emit code for the test. - */ + TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData; + unsigned char lexeme; + OpNode nodes[2]; + Tcl_Obj *const *litObjv = objv + 1; + + if (objc != 1+occdPtr->i.numArgs) { + Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected); + return TCL_ERROR; + } - tokenPtr = exprTokenPtr+2; - code = CompileSubExpr(tokenPtr, infoPtr, envPtr); - if (code != 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; } - tokenPtr += (tokenPtr->numComponents + 1); - - /* - * Emit the jump to the "else" expression if the test was false. - */ - - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpAroundThenFixup); + nodes[1].right = OT_LITERAL; + nodes[1].p.parent = 0; - /* - * Compile the "then" expression. Note that if a subexpression is only - * a primary, we need to try to convert it to numeric. We do this to - * support Tcl's policy of interpreting operands if at all possible as - * first integers, else floating-point numbers. - */ + return ExecConstantExprTree(interp, nodes, 0, &litObjv); +} + +/* + *---------------------------------------------------------------------- + * + * TclSortingOpCmd -- + * Implements the commands: <, <=, >, >=, ==, eq + * in the ::tcl::mathop namespace. These commands are defined for + * arbitrary number of arguments by computing the AND of the base + * operator applied to all neighbor argument pairs. + * + * Results: + * A standard Tcl return code and result left in interp. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - infoPtr->hasOperators = 0; - code = CompileSubExpr(tokenPtr, infoPtr, envPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr += (tokenPtr->numComponents + 1); - if (!infoPtr->hasOperators) { - TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); - } +int +TclSortingOpCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + int code = TCL_OK; - /* - * Emit an unconditional jump around the "else" condExpr. - */ - - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpAroundElseFixup); + if (objc < 3) { + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); + } else { + TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData; + Tcl_Obj **litObjv = (Tcl_Obj **) TclStackAlloc(interp, + 2*(objc-2)*sizeof(Tcl_Obj *)); + OpNode *nodes = (OpNode *) TclStackAlloc(interp, + 2*(objc-2)*sizeof(OpNode)); + unsigned char lexeme; + int i, lastAnd = 1; + Tcl_Obj *const *litObjPtrPtr = litObjv; + + ParseLexeme(occdPtr->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); + } + litObjv[2*(objc-2)-1] = objv[objc-1]; - /* - * Compile the "else" expression. - */ + 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; - envPtr->currStackDepth = savedStackDepth; - elseCodeOffset = (envPtr->codeNext - envPtr->codeStart); - infoPtr->hasOperators = 0; - code = CompileSubExpr(tokenPtr, infoPtr, envPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr += (tokenPtr->numComponents + 1); - if (!infoPtr->hasOperators) { - TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); - } + nodes[0].right = lastAnd; + nodes[lastAnd].p.parent = 0; - /* - * Fix up the second jump around the "else" expression. - */ + code = ExecConstantExprTree(interp, nodes, 0, &litObjPtrPtr); - dist = (envPtr->codeNext - envPtr->codeStart) - - jumpAroundElseFixup.codeOffset; - if (TclFixupForwardJump(envPtr, &jumpAroundElseFixup, dist, 127)) { - /* - * Update the else expression's starting code offset since it - * moved down 3 bytes too. - */ - - elseCodeOffset += 3; + TclStackFree(interp, nodes); + TclStackFree(interp, litObjv); } - - /* - * Fix up the first jump to the "else" expression if the test was false. - */ - - dist = (elseCodeOffset - jumpAroundThenFixup.codeOffset); - TclFixupForwardJump(envPtr, &jumpAroundThenFixup, dist, 127); - *endPtrPtr = tokenPtr; - - done: - envPtr->currStackDepth = savedStackDepth + 1; return code; } /* *---------------------------------------------------------------------- * - * CompileMathFuncCall -- - * - * This procedure compiles a call on a math function in an expression: - * mathFuncCall ::= funcName '(' [condExpr {',' condExpr}] ')' + * 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: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_OK is returned, a pointer to the token just after - * the last one in the subexpression is stored at the address in - * endPtrPtr. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. + * 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(exprTokenPtr, funcName, infoPtr, envPtr, endPtrPtr) - Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token - * containing the math function call. */ - CONST char *funcName; /* Name of the math function. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - CompileEnv *envPtr; /* Holds resulting instructions. */ - Tcl_Token **endPtrPtr; /* If successful, a pointer to the token - * just after the last token in the - * subexpression is stored here. */ +int +TclVariadicOpCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) { - Tcl_Interp *interp = infoPtr->interp; - Interp *iPtr = (Interp *) interp; - MathFunc *mathFuncPtr; - Tcl_HashEntry *hPtr; - Tcl_Token *tokenPtr, *afterSubexprPtr; - int code, i; - - /* - * Look up the MathFunc record for the function. - */ + TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData; + unsigned char lexeme; + int code; - code = TCL_OK; - hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); - if (hPtr == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown math function \"", funcName, "\"", (char *) NULL); - code = TCL_ERROR; - goto done; + if (objc < 2) { + Tcl_SetObjResult(interp, Tcl_NewIntObj(occdPtr->i.identity)); + return TCL_OK; } - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - /* - * If not a builtin function, push an object with the function's name. - */ - - if (mathFuncPtr->builtinFuncIndex < 0) { - TclEmitPush(TclRegisterNewLiteral(envPtr, funcName, -1), envPtr); - } + 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; + } - /* - * Compile any arguments for the function. - */ + code = ExecConstantExprTree(interp, nodes, 0, &litObjPtrPtr); - tokenPtr = exprTokenPtr+2; - afterSubexprPtr = exprTokenPtr + (exprTokenPtr->numComponents + 1); - if (mathFuncPtr->numArgs > 0) { - for (i = 0; i < mathFuncPtr->numArgs; i++) { - if (tokenPtr == afterSubexprPtr) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "too few arguments for math function", -1); - code = TCL_ERROR; - goto done; - } - code = CompileSubExpr(tokenPtr, infoPtr, envPtr); - if (code != TCL_OK) { - goto done; + Tcl_DecrRefCount(litObjv[decrMe]); + return code; + } else { + Tcl_Obj *const *litObjv = objv + 1; + OpNode *nodes = (OpNode *) TclStackAlloc(interp, + (objc-1)*sizeof(OpNode)); + int i, lastOp = OT_LITERAL; + + nodes[0].lexeme = START; + nodes[0].mark = MARK_RIGHT; + if (lexeme == EXPON) { + for (i=objc-2; i>0; i-- ) { + nodes[i].lexeme = lexeme; + nodes[i].mark = MARK_LEFT; + nodes[i].left = OT_LITERAL; + nodes[i].right = lastOp; + if (lastOp >= 0) { + nodes[lastOp].p.parent = i; + } + lastOp = i; + } + } else { + for (i=1; i<objc-1; i++ ) { + nodes[i].lexeme = lexeme; + nodes[i].mark = MARK_LEFT; + nodes[i].left = lastOp; + if (lastOp >= 0) { + nodes[lastOp].p.parent = i; + } + nodes[i].right = OT_LITERAL; + lastOp = i; } - tokenPtr += (tokenPtr->numComponents + 1); } - if (tokenPtr != afterSubexprPtr) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "too many arguments for math function", -1); - code = TCL_ERROR; - goto done; - } - } else if (tokenPtr != afterSubexprPtr) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "too many arguments for math function", -1); - code = TCL_ERROR; - 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 - * function name itself. - */ + nodes[0].right = lastOp; + nodes[lastOp].p.parent = 0; - if (mathFuncPtr->builtinFuncIndex >= 0) { /* a builtin function */ - /* - * Adjust the current stack depth by the number of arguments - * of the builtin function. This cannot be handled by the - * TclEmitInstInt1 macro as the number of arguments is not - * passed as an operand. - */ + code = ExecConstantExprTree(interp, nodes, 0, &litObjv); - if (envPtr->maxStackDepth < envPtr->currStackDepth) { - envPtr->maxStackDepth = envPtr->currStackDepth; - } - TclEmitInstInt1(INST_CALL_BUILTIN_FUNC1, - mathFuncPtr->builtinFuncIndex, envPtr); - envPtr->currStackDepth -= mathFuncPtr->numArgs; - } else { - TclEmitInstInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr); - } - *endPtrPtr = afterSubexprPtr; + TclStackFree(interp, nodes); - done: - return code; + return code; + } } /* *---------------------------------------------------------------------- * - * LogSyntaxError -- - * - * This procedure is invoked after an error occurs when compiling an - * expression. It sets the interpreter result to an error message - * describing the error. + * 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: - * Sets the interpreter result to an error message describing the - * expression that was being compiled when the error occurred. + * None. * *---------------------------------------------------------------------- */ -static void -LogSyntaxError(infoPtr) - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ +int +TclNoIdentOpCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) { - int numBytes = (infoPtr->lastChar - infoPtr->expr); - char buffer[100]; - - sprintf(buffer, "syntax error in expression \"%.*s\"", - ((numBytes > 60)? 60 : numBytes), infoPtr->expr); - Tcl_ResetResult(infoPtr->interp); - Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp), - buffer, (char *) NULL); + TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData; + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected); + return TCL_ERROR; + } + return TclVariadicOpCmd(clientData, interp, objc, objv); } +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |