Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: downloads/tcl8.5.2/generic/tclCompExpr.c @ 63

Last change on this file since 63 was 25, checked in by landauf, 17 years ago

added tcl to libs

File size: 80.2 KB
Line 
1/*
2 * tclCompExpr.c --
3 *
4 *      This file contains the code to parse and compile Tcl expressions
5 *      and implementations of the Tcl commands corresponding to expression
6 *      operators, such as the command ::tcl::mathop::+ .
7 *
8 * Contributions from Don Porter, NIST, 2006-2007. (not subject to US copyright)
9 *
10 * See the file "license.terms" for information on usage and redistribution of
11 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
12 *
13 * RCS: @(#) $Id: tclCompExpr.c,v 1.97 2008/02/28 20:40:24 dgp Exp $
14 */
15
16#include "tclInt.h"
17#include "tclCompile.h"         /* CompileEnv */
18
19/*
20 * Expression parsing takes place in the routine ParseExpr().  It takes a
21 * string as input, parses that string, and generates a representation of
22 * the expression in the form of a tree of operators, a list of literals,
23 * a list of function names, and an array of Tcl_Token's within a Tcl_Parse
24 * struct.  The tree is composed of OpNodes.
25 */
26
27typedef struct OpNode {
28    int left;                   /* "Pointer" to the left operand. */
29    int right;                  /* "Pointer" to the right operand. */
30    union {
31        int parent;             /* "Pointer" to the parent operand. */
32        int prev;               /* "Pointer" joining incomplete tree stack */
33    } p;
34    unsigned char lexeme;       /* Code that identifies the operator. */
35    unsigned char precedence;   /* Precedence of the operator */
36    unsigned char mark;         /* Mark used to control traversal. */
37    unsigned char constant;     /* Flag marking constant subexpressions. */
38} OpNode;
39
40/*
41 * The storage for the tree is dynamically allocated array of OpNodes.  The
42 * array is grown as parsing needs dictate according to a scheme similar to
43 * Tcl's string growth algorithm, so that the resizing costs are O(N) and so
44 * that we use at least half the memory allocated as expressions get large.
45 *
46 * Each OpNode in the tree represents an operator in the expression, either
47 * unary or binary.  When parsing is completed successfully, a binary operator
48 * OpNode will have its left and right fields filled with "pointers" to its
49 * left and right operands.  A unary operator OpNode will have its right field
50 * filled with a pointer to its single operand.  When an operand is a
51 * subexpression the "pointer" takes the form of the index -- a non-negative
52 * integer -- into the OpNode storage array where the root of that
53 * subexpression parse tree is found. 
54 *
55 * Non-operator elements of the expression do not get stored in the OpNode
56 * tree.  They are stored in the other structures according to their type.
57 * Literal values get appended to the literal list.  Elements that denote
58 * forms of quoting or substitution known to the Tcl parser get stored as
59 * Tcl_Tokens.  These non-operator elements of the expression are the
60 * leaves of the completed parse tree.  When an operand of an OpNode is
61 * one of these leaf elements, the following negative integer codes are used
62 * to indicate which kind of elements it is.
63 */
64
65enum OperandTypes {
66    OT_LITERAL = -3,    /* Operand is a literal in the literal list */
67    OT_TOKENS = -2,     /* Operand is sequence of Tcl_Tokens */
68    OT_EMPTY = -1       /* "Operand" is an empty string.  This is a
69                         * special case used only to represent the
70                         * EMPTY lexeme.  See below. */
71};
72
73/*
74 * Readable macros to test whether a "pointer" value points to an operator.
75 * They operate on the "non-negative integer -> operator; negative integer ->
76 * a non-operator OperandType" distinction.
77 */
78
79#define IsOperator(l)   ((l) >= 0)
80#define NotOperator(l)  ((l) < 0)
81
82/*
83 * Note that it is sufficient to store in the tree just the type of leaf
84 * operand, without any explicit pointer to which leaf.  This is true because
85 * the traversals of the completed tree we perform are known to visit
86 * the leaves in the same order as the original parse.
87 *
88 * In a completed parse tree, those OpNodes that are themselves (roots of
89 * subexpression trees that are) operands of some operator store in their
90 * p.parent field a "pointer" to the OpNode of that operator.  The p.parent
91 * field permits a traversal of the tree within a * non-recursive routine
92 * (ConvertTreeToTokens() and CompileExprTree()).  This means that even
93 * expression trees of great depth pose no risk of blowing the C stack.
94 *
95 * While the parse tree is being constructed, the same memory space is used
96 * to hold the p.prev field which chains together a stack of incomplete
97 * trees awaiting their right operands.
98 *
99 * The lexeme field is filled in with the lexeme of the operator that is
100 * returned by the ParseLexeme() routine.  Only lexemes for unary and
101 * binary operators get stored in an OpNode.  Other lexmes get different
102 * treatement.
103 *
104 * The precedence field provides a place to store the precedence of the
105 * operator, so it need not be looked up again and again.
106 *
107 * The mark field is use to control the traversal of the tree, so
108 * that it can be done non-recursively.  The mark values are:
109 */
110
111enum Marks {
112    MARK_LEFT,          /* Next step of traversal is to visit left subtree */
113    MARK_RIGHT,         /* Next step of traversal is to visit right subtree */
114    MARK_PARENT         /* Next step of traversal is to return to parent */
115};
116
117/*
118 * The constant field is a boolean flag marking which subexpressions are
119 * completely known at compile time, and are eligible for computing then
120 * rather than waiting until run time.
121 */
122
123/*
124 * Each lexeme belongs to one of four categories, which determine
125 * its place in the parse tree.  We use the two high bits of the
126 * (unsigned char) value to store a NODE_TYPE code.
127 */
128
129#define NODE_TYPE       0xC0
130
131/*
132 * The four category values are LEAF, UNARY, and BINARY, explained below,
133 * and "uncategorized", which is used either temporarily, until context
134 * determines which of the other three categories is correct, or for
135 * lexemes like INVALID, which aren't really lexemes at all, but indicators
136 * of a parsing error.  Note that the codes must be distinct to distinguish
137 * categories, but need not take the form of a bit array.
138 */
139
140#define BINARY          0x40    /* This lexeme is a binary operator.  An
141                                 * OpNode representing it should go into the
142                                 * parse tree, and two operands should be
143                                 * parsed for it in the expression.  */
144#define UNARY           0x80    /* This lexeme is a unary operator.  An OpNode
145                                 * representing it should go into the parse
146                                 * tree, and one operand should be parsed for
147                                 * it in the expression. */
148#define LEAF            0xC0    /* This lexeme is a leaf operand in the parse
149                                 * tree.  No OpNode will be placed in the tree
150                                 * for it.  Either a literal value will be
151                                 * appended to the list of literals in this
152                                 * expression, or appropriate Tcl_Tokens will
153                                 * be appended in a Tcl_Parse struct to
154                                 * represent those leaves that require some
155                                 * form of substitution.
156                                 */
157
158/* Uncategorized lexemes */
159
160#define PLUS            1       /* Ambiguous.  Resolves to UNARY_PLUS or
161                                 * BINARY_PLUS according to context. */
162#define MINUS           2       /* Ambiguous.  Resolves to UNARY_MINUS or
163                                 * BINARY_MINUS according to context. */
164#define BAREWORD        3       /* Ambigous.  Resolves to BOOLEAN or to
165                                 * FUNCTION or a parse error according to
166                                 * context and value. */
167#define INCOMPLETE      4       /* A parse error.  Used only when the single
168                                 * "=" is encountered.  */
169#define INVALID         5       /* A parse error.  Used when any punctuation
170                                 * appears that's not a supported operator. */
171
172/* Leaf lexemes */
173
174#define NUMBER          ( LEAF | 1)     /* For literal numbers */
175#define SCRIPT          ( LEAF | 2)     /* Script substitution; [foo] */
176#define BOOLEAN         ( LEAF | BAREWORD)      /* For literal booleans */
177#define BRACED          ( LEAF | 4)     /* Braced string; {foo bar} */
178#define VARIABLE        ( LEAF | 5)     /* Variable substitution; $x */
179#define QUOTED          ( LEAF | 6)     /* Quoted string; "foo $bar [soom]" */
180#define EMPTY           ( LEAF | 7)     /* Used only for an empty argument
181                                         * list to a function.  Represents
182                                         * the empty string within parens in
183                                         * the expression: rand() */
184
185/* Unary operator lexemes */
186
187#define UNARY_PLUS      ( UNARY | PLUS)
188#define UNARY_MINUS     ( UNARY | MINUS)
189#define FUNCTION        ( UNARY | BAREWORD)     /* This is a bit of "creative
190                                         * interpretation" on the part of the
191                                         * parser.  A function call is parsed
192                                         * into the parse tree according to
193                                         * the perspective that the function
194                                         * name is a unary operator and its
195                                         * argument list, enclosed in parens,
196                                         * is its operand.  The additional
197                                         * requirements not implied generally
198                                         * by treatment as a unary operator --
199                                         * for example, the requirement that
200                                         * the operand be enclosed in parens --
201                                         * are hard coded in the relevant
202                                         * portions of ParseExpr().  We trade
203                                         * off the need to include such
204                                         * exceptional handling in the code
205                                         * against the need we would otherwise
206                                         * have for more lexeme categories. */
207#define START           ( UNARY | 4)    /* This lexeme isn't parsed from the
208                                         * expression text at all.  It
209                                         * represents the start of the
210                                         * expression and sits at the root of
211                                         * the parse tree where it serves as
212                                         * the start/end point of traversals. */
213#define OPEN_PAREN      ( UNARY | 5)    /* Another bit of creative
214                                         * interpretation, where we treat "("
215                                         * as a unary operator with the
216                                         * sub-expression between it and its
217                                         * matching ")" as its operand. See
218                                         * CLOSE_PAREN below. */
219#define NOT             ( UNARY | 6)
220#define BIT_NOT         ( UNARY | 7)
221
222/* Binary operator lexemes */
223
224#define BINARY_PLUS     ( BINARY |  PLUS)
225#define BINARY_MINUS    ( BINARY |  MINUS)
226#define COMMA           ( BINARY |  3)  /* The "," operator is a low precedence
227                                         * binary operator that separates the
228                                         * arguments in a function call.  The
229                                         * additional constraint that this
230                                         * operator can only legally appear
231                                         * at the right places within a
232                                         * function call argument list are
233                                         * hard coded within ParseExpr().  */
234#define MULT            ( BINARY |  4)
235#define DIVIDE          ( BINARY |  5)
236#define MOD             ( BINARY |  6)
237#define LESS            ( BINARY |  7)
238#define GREATER         ( BINARY |  8)
239#define BIT_AND         ( BINARY |  9)
240#define BIT_XOR         ( BINARY | 10)
241#define BIT_OR          ( BINARY | 11)
242#define QUESTION        ( BINARY | 12)  /* These two lexemes make up the */
243#define COLON           ( BINARY | 13)  /* ternary conditional operator,
244                                         * $x ? $y : $z .  We treat them as
245                                         * two binary operators to avoid
246                                         * another lexeme category, and
247                                         * code the additional constraints
248                                         * directly in ParseExpr().  For
249                                         * instance, the right operand of
250                                         * a "?" operator must be a ":"
251                                         * operator. */
252#define LEFT_SHIFT      ( BINARY | 14)
253#define RIGHT_SHIFT     ( BINARY | 15)
254#define LEQ             ( BINARY | 16)
255#define GEQ             ( BINARY | 17)
256#define EQUAL           ( BINARY | 18)
257#define NEQ             ( BINARY | 19)
258#define AND             ( BINARY | 20)
259#define OR              ( BINARY | 21)
260#define STREQ           ( BINARY | 22)
261#define STRNEQ          ( BINARY | 23)
262#define EXPON           ( BINARY | 24)  /* Unlike the other binary operators,
263                                         * EXPON is right associative and this
264                                         * distinction is coded directly in
265                                         * ParseExpr(). */
266#define IN_LIST         ( BINARY | 25)
267#define NOT_IN_LIST     ( BINARY | 26)
268#define CLOSE_PAREN     ( BINARY | 27)  /* By categorizing the CLOSE_PAREN
269                                         * lexeme as a BINARY operator, the
270                                         * normal parsing rules for binary
271                                         * operators assure that a close paren
272                                         * will not directly follow another
273                                         * operator, and the machinery already
274                                         * in place to connect operands to
275                                         * operators according to precedence
276                                         * performs most of the work of
277                                         * matching open and close parens for
278                                         * us.  In the end though, a close
279                                         * paren is not really a binary
280                                         * operator, and some special coding
281                                         * in ParseExpr() make sure we never
282                                         * put an actual CLOSE_PAREN node
283                                         * in the parse tree.   The
284                                         * sub-expression between parens
285                                         * becomes the single argument of
286                                         * the matching OPEN_PAREN unary
287                                         * operator. */
288#define END             ( BINARY | 28)  /* This lexeme represents the end of
289                                         * the string being parsed.  Treating
290                                         * it as a binary operator follows the
291                                         * same logic as the CLOSE_PAREN lexeme
292                                         * and END pairs with START, in the
293                                         * same way that CLOSE_PAREN pairs with
294                                         * OPEN_PAREN. */
295/*
296 * When ParseExpr() builds the parse tree it must choose which operands to
297 * connect to which operators.  This is done according to operator precedence.
298 * The greater an operator's precedence the greater claim it has to link to
299 * an available operand.  The Precedence enumeration lists the precedence
300 * values used by Tcl expression operators, from lowest to highest claim.
301 * Each precedence level is commented with the operators that hold that
302 * precedence.
303 */
304
305enum Precedence {
306    PREC_END = 1,       /* END */
307    PREC_START,         /* START */
308    PREC_CLOSE_PAREN,   /* ")" */
309    PREC_OPEN_PAREN,    /* "(" */
310    PREC_COMMA,         /* "," */
311    PREC_CONDITIONAL,   /* "?", ":" */
312    PREC_OR,            /* "||" */
313    PREC_AND,           /* "&&" */
314    PREC_BIT_OR,        /* "|" */
315    PREC_BIT_XOR,       /* "^" */
316    PREC_BIT_AND,       /* "&" */
317    PREC_EQUAL,         /* "==", "!=", "eq", "ne", "in", "ni" */
318    PREC_COMPARE,       /* "<", ">", "<=", ">=" */
319    PREC_SHIFT,         /* "<<", ">>" */
320    PREC_ADD,           /* "+", "-" */
321    PREC_MULT,          /* "*", "/", "%" */
322    PREC_EXPON,         /* "**" */
323    PREC_UNARY          /* "+", "-", FUNCTION, "!", "~" */
324};
325
326/*
327 * Here the same information contained in the comments above is stored
328 * in inverted form, so that given a lexeme, one can quickly look up
329 * its precedence value.
330 */
331
332static const unsigned char prec[] = {
333    /* Non-operator lexemes */
334    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
335    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
336    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
337    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
338    0,
339    /* Binary operator lexemes */
340    PREC_ADD,           /* BINARY_PLUS */
341    PREC_ADD,           /* BINARY_MINUS */
342    PREC_COMMA,         /* COMMA */
343    PREC_MULT,          /* MULT */
344    PREC_MULT,          /* DIVIDE */
345    PREC_MULT,          /* MOD */
346    PREC_COMPARE,       /* LESS */
347    PREC_COMPARE,       /* GREATER */
348    PREC_BIT_AND,       /* BIT_AND */
349    PREC_BIT_XOR,       /* BIT_XOR */
350    PREC_BIT_OR,        /* BIT_OR */
351    PREC_CONDITIONAL,   /* QUESTION */
352    PREC_CONDITIONAL,   /* COLON */
353    PREC_SHIFT,         /* LEFT_SHIFT */
354    PREC_SHIFT,         /* RIGHT_SHIFT */
355    PREC_COMPARE,       /* LEQ */
356    PREC_COMPARE,       /* GEQ */
357    PREC_EQUAL,         /* EQUAL */
358    PREC_EQUAL,         /* NEQ */
359    PREC_AND,           /* AND */
360    PREC_OR,            /* OR */
361    PREC_EQUAL,         /* STREQ */
362    PREC_EQUAL,         /* STRNEQ */
363    PREC_EXPON,         /* EXPON */
364    PREC_EQUAL,         /* IN_LIST */
365    PREC_EQUAL,         /* NOT_IN_LIST */
366    PREC_CLOSE_PAREN,   /* CLOSE_PAREN */
367    PREC_END,           /* END */
368    /* Expansion room for more binary operators */
369    0,  0,  0,
370    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
371    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
372    0, 
373    /* Unary operator lexemes */
374    PREC_UNARY,         /* UNARY_PLUS */
375    PREC_UNARY,         /* UNARY_MINUS */
376    PREC_UNARY,         /* FUNCTION */
377    PREC_START,         /* START */
378    PREC_OPEN_PAREN,    /* OPEN_PAREN */
379    PREC_UNARY,         /* NOT*/
380    PREC_UNARY,         /* BIT_NOT*/
381};
382
383/*
384 * A table mapping lexemes to bytecode instructions, used by CompileExprTree().
385 */
386
387static const unsigned char instruction[] = {
388    /* Non-operator lexemes */
389    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
390    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
391    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
392    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
393    0,
394    /* Binary operator lexemes */
395    INST_ADD,           /* BINARY_PLUS */
396    INST_SUB,           /* BINARY_MINUS */
397    0,                  /* COMMA */
398    INST_MULT,          /* MULT */
399    INST_DIV,           /* DIVIDE */
400    INST_MOD,           /* MOD */
401    INST_LT,            /* LESS */
402    INST_GT,            /* GREATER */
403    INST_BITAND,        /* BIT_AND */
404    INST_BITXOR,        /* BIT_XOR */
405    INST_BITOR,         /* BIT_OR */
406    0,                  /* QUESTION */
407    0,                  /* COLON */
408    INST_LSHIFT,        /* LEFT_SHIFT */
409    INST_RSHIFT,        /* RIGHT_SHIFT */
410    INST_LE,            /* LEQ */
411    INST_GE,            /* GEQ */
412    INST_EQ,            /* EQUAL */
413    INST_NEQ,           /* NEQ */
414    0,                  /* AND */
415    0,                  /* OR */
416    INST_STR_EQ,        /* STREQ */
417    INST_STR_NEQ,       /* STRNEQ */
418    INST_EXPON,         /* EXPON */
419    INST_LIST_IN,       /* IN_LIST */
420    INST_LIST_NOT_IN,   /* NOT_IN_LIST */
421    0,                  /* CLOSE_PAREN */
422    0,                  /* END */
423    /* Expansion room for more binary operators */
424    0,  0,  0,
425    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
426    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
427    0, 
428    /* Unary operator lexemes */
429    INST_UPLUS,         /* UNARY_PLUS */
430    INST_UMINUS,        /* UNARY_MINUS */
431    0,                  /* FUNCTION */
432    0,                  /* START */
433    0,                  /* OPEN_PAREN */
434    INST_LNOT,          /* NOT*/
435    INST_BITNOT,        /* BIT_NOT*/
436};
437
438/*
439 * A table mapping a byte value to the corresponding lexeme for use by
440 * ParseLexeme().
441 */
442
443static unsigned char Lexeme[] = {
444        INVALID         /* NUL */,      INVALID         /* SOH */,
445        INVALID         /* STX */,      INVALID         /* ETX */,
446        INVALID         /* EOT */,      INVALID         /* ENQ */,
447        INVALID         /* ACK */,      INVALID         /* BEL */,
448        INVALID         /* BS */,       INVALID         /* HT */,
449        INVALID         /* LF */,       INVALID         /* VT */,
450        INVALID         /* FF */,       INVALID         /* CR */,
451        INVALID         /* SO */,       INVALID         /* SI */,
452        INVALID         /* DLE */,      INVALID         /* DC1 */,
453        INVALID         /* DC2 */,      INVALID         /* DC3 */,
454        INVALID         /* DC4 */,      INVALID         /* NAK */,
455        INVALID         /* SYN */,      INVALID         /* ETB */,
456        INVALID         /* CAN */,      INVALID         /* EM */,
457        INVALID         /* SUB */,      INVALID         /* ESC */,
458        INVALID         /* FS */,       INVALID         /* GS */,
459        INVALID         /* RS */,       INVALID         /* US */,
460        INVALID         /* SPACE */,    0               /* ! or != */,
461        QUOTED          /* " */,        INVALID         /* # */,
462        VARIABLE        /* $ */,        MOD             /* % */,
463        0               /* & or && */,  INVALID         /* ' */,
464        OPEN_PAREN      /* ( */,        CLOSE_PAREN     /* ) */,
465        0               /* * or ** */,  PLUS            /* + */,
466        COMMA           /* , */,        MINUS           /* - */,
467        0               /* . */,        DIVIDE          /* / */,
468        0, 0, 0, 0, 0, 0, 0, 0, 0, 0,                   /* 0-9 */
469        COLON           /* : */,        INVALID         /* ; */,
470        0               /* < or << or <= */,
471        0               /* == or INVALID */,
472        0               /* > or >> or >= */,
473        QUESTION        /* ? */,        INVALID         /* @ */,
474        0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,          /* A-M */
475        0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,          /* N-Z */
476        SCRIPT          /* [ */,        INVALID         /* \ */,
477        INVALID         /* ] */,        BIT_XOR         /* ^ */,
478        INVALID         /* _ */,        INVALID         /* ` */,
479        0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,          /* a-m */
480        0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,          /* n-z */
481        BRACED          /* { */,        0               /* | or || */,
482        INVALID         /* } */,        BIT_NOT         /* ~ */,
483        INVALID         /* DEL */
484};
485
486/*
487 * The JumpList struct is used to create a stack of data needed for the
488 * TclEmitForwardJump() and TclFixupForwardJump() calls that are performed
489 * when compiling the short-circuiting operators QUESTION/COLON, AND, and OR.
490 * Keeping a stack permits the CompileExprTree() routine to be non-recursive.
491 */
492
493typedef struct JumpList {
494    JumpFixup jump;             /* Pass this argument to matching calls of
495                                 * TclEmitForwardJump() and
496                                 * TclFixupForwardJump(). */
497    int depth;                  /* Remember the currStackDepth of the
498                                 * CompileEnv here. */
499    int offset;                 /* Data used to compute jump lengths to pass
500                                 * to TclFixupForwardJump() */
501    int convert;                /* Temporary storage used to compute whether
502                                 * numeric conversion will be needed following
503                                 * the operator we're compiling. */
504    struct JumpList *next;      /* Point to next item on the stack */
505} JumpList;
506
507/*
508 * Declarations for local functions to this file:
509 */
510
511static void             CompileExprTree(Tcl_Interp *interp, OpNode *nodes,
512                            int index, Tcl_Obj *const **litObjvPtr,
513                            Tcl_Obj *const *funcObjv, Tcl_Token *tokenPtr,
514                            CompileEnv *envPtr, int optimize);
515static void             ConvertTreeToTokens(const char *start, int numBytes,
516                            OpNode *nodes, Tcl_Token *tokenPtr,
517                            Tcl_Parse *parsePtr);
518static int              ExecConstantExprTree(Tcl_Interp *interp, OpNode *nodes,
519                            int index, Tcl_Obj * const **litObjvPtr);
520static int              ParseExpr(Tcl_Interp *interp, const char *start,
521                            int numBytes, OpNode **opTreePtr,
522                            Tcl_Obj *litList, Tcl_Obj *funcList,
523                            Tcl_Parse *parsePtr, int parseOnly);
524static int              ParseLexeme(const char *start, int numBytes,
525                            unsigned char *lexemePtr, Tcl_Obj **literalPtr);
526
527
528/*
529 *----------------------------------------------------------------------
530 *
531 * ParseExpr --
532 *
533 *      Given a string, the numBytes bytes starting at start, this function
534 *      parses it as a Tcl expression and constructs a tree representing
535 *      the structure of the expression.  The caller must pass in empty
536 *      lists as the funcList and litList arguments.  The elements of the
537 *      parsed expression are returned to the caller as that tree, a list of
538 *      literal values, a list of function names, and in Tcl_Tokens
539 *      added to a Tcl_Parse struct passed in by the caller.
540 *
541 * Results:
542 *      If the string is successfully parsed as a valid Tcl expression, TCL_OK
543 *      is returned, and data about the expression structure is written to
544 *      the last four arguments.  If the string cannot be parsed as a valid
545 *      Tcl expression, TCL_ERROR is returned, and if interp is non-NULL, an
546 *      error message is written to interp.
547 *
548 * Side effects:
549 *      Memory will be allocated.  If TCL_OK is returned, the caller must
550 *      clean up the returned data structures.  The (OpNode *) value written
551 *      to opTreePtr should be passed to ckfree() and the parsePtr argument
552 *      should be passed to Tcl_FreeParse().  The elements appended to the
553 *      litList and funcList will automatically be freed whenever the
554 *      refcount on those lists indicates they can be freed.
555 *
556 *----------------------------------------------------------------------
557 */
558
559static int
560ParseExpr(
561    Tcl_Interp *interp,         /* Used for error reporting. */
562    const char *start,          /* Start of source string to parse. */
563    int numBytes,               /* Number of bytes in string. */
564    OpNode **opTreePtr,         /* Points to space where a pointer to the
565                                 * allocated OpNode tree should go. */
566    Tcl_Obj *litList,           /* List to append literals to. */
567    Tcl_Obj *funcList,          /* List to append function names to. */
568    Tcl_Parse *parsePtr,        /* Structure to fill with tokens representing
569                                 * those operands that require run time
570                                 * substitutions. */
571    int parseOnly)              /* A boolean indicating whether the caller's
572                                 * aim is just a parse, or whether it will go
573                                 * on to compile the expression.  Different
574                                 * optimizations are appropriate for the
575                                 * two scenarios. */
576{
577    OpNode *nodes = NULL;       /* Pointer to the OpNode storage array where
578                                 * we build the parse tree. */
579    int nodesAvailable = 64;    /* Initial size of the storage array.  This
580                                 * value establishes a minimum tree memory cost
581                                 * of only about 1 kibyte, and is large enough
582                                 * for most expressions to parse with no need
583                                 * for array growth and reallocation. */
584    int nodesUsed = 0;          /* Number of OpNodes filled. */
585    int scanned = 0;            /* Capture number of byte scanned by
586                                 * parsing routines. */
587    int lastParsed;             /* Stores info about what the lexeme parsed
588                                 * the previous pass through the parsing loop
589                                 * was.  If it was an operator, lastParsed is
590                                 * the index of the OpNode for that operator.
591                                 * If it was not an operator, lastParsed holds
592                                 * an OperandTypes value encoding what we
593                                 * need to know about it. */
594    int incomplete;             /* Index of the most recent incomplete tree
595                                 * in the OpNode array.  Heads a stack of
596                                 * incomplete trees linked by p.prev. */
597    int complete = OT_EMPTY;    /* "Index" of the complete tree (that is, a
598                                 * complete subexpression) determined at the
599                                 * moment.   OT_EMPTY is a nonsense value
600                                 * used only to silence compiler warnings.
601                                 * During a parse, complete will always hold
602                                 * an index or an OperandTypes value pointing
603                                 * to an actual leaf at the time the complete
604                                 * tree is needed. */
605
606    /* These variables control generation of the error message. */
607    Tcl_Obj *msg = NULL;        /* The error message. */
608    Tcl_Obj *post = NULL;       /* In a few cases, an additional postscript
609                                 * for the error message, supplying more
610                                 * information after the error msg and
611                                 * location have been reported. */
612    const char *mark = "_@_";   /* In the portion of the complete error message
613                                 * where the error location is reported, this
614                                 * "mark" substring is inserted into the
615                                 * string being parsed to aid in pinpointing
616                                 * the location of the syntax error in the
617                                 * expression. */
618    int insertMark = 0;         /* A boolean controlling whether the "mark"
619                                 * should be inserted. */
620    const int limit = 25;       /* Portions of the error message are
621                                 * constructed out of substrings of the
622                                 * original expression.  In order to keep the
623                                 * error message readable, we impose this limit
624                                 * on the substring size we extract. */
625
626    TclParseInit(interp, start, numBytes, parsePtr);
627
628    nodes = (OpNode *) attemptckalloc(nodesAvailable * sizeof(OpNode));
629    if (nodes == NULL) {
630        TclNewLiteralStringObj(msg, "not enough memory to parse expression");
631        goto error;
632    }
633
634    /* Initialize the parse tree with the special "START" node. */
635    nodes->lexeme = START;
636    nodes->precedence = prec[START];
637    nodes->mark = MARK_RIGHT;
638    nodes->constant = 1;
639    incomplete = lastParsed = nodesUsed;
640    nodesUsed++;
641
642    /*
643     * Main parsing loop parses one lexeme per iteration.  We exit the
644     * loop only when there's a syntax error with a "goto error" which
645     * takes us to the error handling code following the loop, or when
646     * we've successfully completed the parse and we return to the caller.
647     */
648
649    while (1) {
650        OpNode *nodePtr;        /* Points to the OpNode we may fill this
651                                 * pass through the loop. */
652        unsigned char lexeme;   /* The lexeme we parse this iteration. */
653        Tcl_Obj *literal;       /* Filled by the ParseLexeme() call when
654                                 * a literal is parsed that has a Tcl_Obj
655                                 * rep worth preserving. */
656        const char *lastStart = start - scanned;
657                                /* Compute where the lexeme parsed the
658                                 * previous pass through the loop began.
659                                 * This is helpful for detecting invalid
660                                 * octals and providing more complete error
661                                 * messages. */
662
663        /*
664         * Each pass through this loop adds up to one more OpNode. Allocate
665         * space for one if required.
666         */
667
668        if (nodesUsed >= nodesAvailable) {
669            int size = nodesUsed * 2;
670            OpNode *newPtr;
671
672            do {
673                newPtr = (OpNode *) attemptckrealloc((char *) nodes,
674                        (unsigned int) size * sizeof(OpNode));
675            } while ((newPtr == NULL)
676                    && ((size -= (size - nodesUsed) / 2) > nodesUsed));
677            if (newPtr == NULL) {
678                TclNewLiteralStringObj(msg,
679                        "not enough memory to parse expression");
680                goto error;
681            }
682            nodesAvailable = size;
683            nodes = newPtr;
684        }
685        nodePtr = nodes + nodesUsed;
686
687        /* Skip white space between lexemes. */
688        scanned = TclParseAllWhiteSpace(start, numBytes);
689        start += scanned;
690        numBytes -= scanned;
691
692        scanned = ParseLexeme(start, numBytes, &lexeme, &literal);
693
694        /* Use context to categorize the lexemes that are ambiguous. */
695        if ((NODE_TYPE & lexeme) == 0) {
696            switch (lexeme) {
697            case INVALID:
698                msg = Tcl_ObjPrintf(
699                        "invalid character \"%.*s\"", scanned, start);
700                goto error;
701            case INCOMPLETE:
702                msg = Tcl_ObjPrintf(
703                        "incomplete operator \"%.*s\"", scanned, start);
704                goto error;
705            case BAREWORD:
706
707                /*
708                 * Most barewords in an expression are a syntax error.
709                 * The exceptions are that when a bareword is followed by
710                 * an open paren, it might be a function call, and when the
711                 * bareword is a legal literal boolean value, we accept that
712                 * as well.
713                 */
714
715                if (start[scanned+TclParseAllWhiteSpace(
716                        start+scanned, numBytes-scanned)] == '(') {
717                    lexeme = FUNCTION;
718
719                    /*
720                     * When we compile the expression we'll need the function
721                     * name, and there's no place in the parse tree to store
722                     * it, so we keep a separate list of all the function
723                     * names we've parsed in the order we found them.
724                     */
725
726                    Tcl_ListObjAppendElement(NULL, funcList, literal);
727                } else {
728                    int b;
729                    if (Tcl_GetBooleanFromObj(NULL, literal, &b) == TCL_OK) {
730                        lexeme = BOOLEAN;
731                    } else {
732                        Tcl_DecrRefCount(literal);
733                        msg = Tcl_ObjPrintf(
734                                "invalid bareword \"%.*s%s\"",
735                                (scanned < limit) ? scanned : limit - 3, start,
736                                (scanned < limit) ? "" : "...");
737                        post = Tcl_ObjPrintf(
738                                "should be \"$%.*s%s\" or \"{%.*s%s}\"",
739                                (scanned < limit) ? scanned : limit - 3,
740                                start, (scanned < limit) ? "" : "...",
741                                (scanned < limit) ? scanned : limit - 3,
742                                start, (scanned < limit) ? "" : "...");
743                        Tcl_AppendPrintfToObj(post,
744                                " or \"%.*s%s(...)\" or ...",
745                                (scanned < limit) ? scanned : limit - 3,
746                                start, (scanned < limit) ? "" : "...");
747                        if (NotOperator(lastParsed)) {
748                            if ((lastStart[0] == '0')
749                                    && ((lastStart[1] == 'o')
750                                    || (lastStart[1] == 'O'))
751                                    && (lastStart[2] >= '0')
752                                    && (lastStart[2] <= '9')) {
753                                const char *end = lastStart + 2;
754                                Tcl_Obj* copy;
755                                while (isdigit(*end)) {
756                                    end++;
757                                }
758                                copy = Tcl_NewStringObj(lastStart,
759                                        end - lastStart);
760                                if (TclCheckBadOctal(NULL,
761                                        Tcl_GetString(copy))) {
762                                    Tcl_AppendToObj(post,
763                                            "(invalid octal number?)", -1);
764                                }
765                                Tcl_DecrRefCount(copy);
766                            }
767                            scanned = 0;
768                            insertMark = 1;
769                            parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
770                        }
771                        goto error;
772                    }
773                }
774                break;
775            case PLUS:
776            case MINUS:
777                if (IsOperator(lastParsed)) {
778
779                    /*
780                     * A "+" or "-" coming just after another operator
781                     * must be interpreted as a unary operator.
782                     */
783
784                    lexeme |= UNARY;
785                } else {
786                    lexeme |= BINARY;
787                }
788            }
789        }       /* Uncategorized lexemes */
790
791        /* Handle lexeme based on its category. */
792        switch (NODE_TYPE & lexeme) {
793
794        /*
795         * Each LEAF results in either a literal getting appended to the
796         * litList, or a sequence of Tcl_Tokens representing a Tcl word
797         * getting appended to the parsePtr->tokens.  No OpNode is filled
798         * for this lexeme.
799         */
800
801        case LEAF: {
802            Tcl_Token *tokenPtr;
803            const char *end = start;
804            int wordIndex;
805            int code = TCL_OK;
806
807            /*
808             * A leaf operand appearing just after something that's not an
809             * operator is a syntax error.
810             */
811
812            if (NotOperator(lastParsed)) {
813                msg = Tcl_ObjPrintf("missing operator at %s", mark);
814                if (lastStart[0] == '0') {
815                    Tcl_Obj *copy = Tcl_NewStringObj(lastStart,
816                            start + scanned - lastStart);
817                    if (TclCheckBadOctal(NULL, Tcl_GetString(copy))) {
818                        TclNewLiteralStringObj(post,
819                                "looks like invalid octal number");
820                    }
821                    Tcl_DecrRefCount(copy);
822                }
823                scanned = 0;
824                insertMark = 1;
825                parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
826
827                /* Free any literal to avoid a memleak. */
828                if ((lexeme == NUMBER) || (lexeme == BOOLEAN)) {
829                    Tcl_DecrRefCount(literal);
830                }
831                goto error;
832            }
833
834            switch (lexeme) {
835            case NUMBER:
836            case BOOLEAN: 
837                /*
838                 * TODO: Consider using a dict or hash to collapse all
839                 * duplicate literals into a single representative value.
840                 * (Like what is done with [split $s {}]).
841                 * Pro: ~75% memory saving on expressions like
842                 *      {1+1+1+1+1+.....+1} (Convert "pointer + Tcl_Obj" cost
843                 *      to "pointer" cost only)
844                 * Con: Cost of the dict store/retrieve on every literal
845                 *      in every expression when expressions like the above
846                 *      tend to be uncommon.
847                 *      The memory savings is temporary; Compiling to bytecode
848                 *      will collapse things as literals are registered
849                 *      anyway, so the savings applies only to the time
850                 *      between parsing and compiling.  Possibly important
851                 *      due to high-water mark nature of memory allocation.
852                 */
853                Tcl_ListObjAppendElement(NULL, litList, literal);
854                complete = lastParsed = OT_LITERAL;
855                start += scanned;
856                numBytes -= scanned;
857                continue;
858           
859            default:
860                break;
861            }
862
863            /*
864             * Remaining LEAF cases may involve filling Tcl_Tokens, so
865             * make room for at least 2 more tokens.
866             */
867
868            TclGrowParseTokenArray(parsePtr, 2);
869            wordIndex = parsePtr->numTokens;
870            tokenPtr = parsePtr->tokenPtr + wordIndex;
871            tokenPtr->type = TCL_TOKEN_WORD;
872            tokenPtr->start = start;
873            parsePtr->numTokens++;
874
875            switch (lexeme) {
876            case QUOTED:
877                code = Tcl_ParseQuotedString(NULL, start, numBytes,
878                        parsePtr, 1, &end);
879                scanned = end - start;
880                break;
881
882            case BRACED:
883                code = Tcl_ParseBraces(NULL, start, numBytes,
884                            parsePtr, 1, &end);
885                scanned = end - start;
886                break;
887
888            case VARIABLE:
889                code = Tcl_ParseVarName(NULL, start, numBytes, parsePtr, 1);
890
891                /*
892                 * Handle the quirk that Tcl_ParseVarName reports a successful
893                 * parse even when it gets only a "$" with no variable name.
894                 */
895
896                tokenPtr = parsePtr->tokenPtr + wordIndex + 1;
897                if (code == TCL_OK && tokenPtr->type != TCL_TOKEN_VARIABLE) {
898                    TclNewLiteralStringObj(msg, "invalid character \"$\"");
899                    goto error;
900                }
901                scanned = tokenPtr->size;
902                break;
903
904            case SCRIPT: {
905                Tcl_Parse *nestedPtr =
906                        (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse));
907
908                tokenPtr = parsePtr->tokenPtr + parsePtr->numTokens;
909                tokenPtr->type = TCL_TOKEN_COMMAND;
910                tokenPtr->start = start;
911                tokenPtr->numComponents = 0;
912
913                end = start + numBytes;
914                start++;
915                while (1) {
916                    code = Tcl_ParseCommand(interp, start, (end - start), 1,
917                            nestedPtr);
918                    if (code != TCL_OK) {
919                        parsePtr->term = nestedPtr->term;
920                        parsePtr->errorType = nestedPtr->errorType;
921                        parsePtr->incomplete = nestedPtr->incomplete;
922                        break;
923                    }
924                    start = (nestedPtr->commandStart + nestedPtr->commandSize);
925                    Tcl_FreeParse(nestedPtr);
926                    if ((nestedPtr->term < end) && (*(nestedPtr->term) == ']')
927                            && !(nestedPtr->incomplete)) {
928                        break;
929                    }
930
931                    if (start == end) {
932                        TclNewLiteralStringObj(msg, "missing close-bracket");
933                        parsePtr->term = tokenPtr->start;
934                        parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
935                        parsePtr->incomplete = 1;
936                        code = TCL_ERROR;
937                        break;
938                    }
939                }
940                TclStackFree(interp, nestedPtr);
941                end = start;
942                start = tokenPtr->start;
943                scanned = end - start;
944                tokenPtr->size = scanned;
945                parsePtr->numTokens++;
946                break;
947            }
948            }
949            if (code != TCL_OK) {
950
951                /*
952                 * Here we handle all the syntax errors generated by
953                 * the Tcl_Token generating parsing routines called in the
954                 * switch just above.  If the value of parsePtr->incomplete
955                 * is 1, then the error was an unbalanced '[', '(', '{',
956                 * or '"' and parsePtr->term is pointing to that unbalanced
957                 * character.  If the value of parsePtr->incomplete is 0,
958                 * then the error is one of lacking whitespace following a
959                 * quoted word, for example: expr {[an error {foo}bar]},
960                 * and parsePtr->term points to where the whitespace is
961                 * missing.  We reset our values of start and scanned so that
962                 * when our error message is constructed, the location of
963                 * the syntax error is sure to appear in it, even if the
964                 * quoted expression is truncated.
965                 */
966
967                start = parsePtr->term;
968                scanned = parsePtr->incomplete;
969                goto error;
970            }
971
972            tokenPtr = parsePtr->tokenPtr + wordIndex;
973            tokenPtr->size = scanned;
974            tokenPtr->numComponents = parsePtr->numTokens - wordIndex - 1;
975            if (!parseOnly && ((lexeme == QUOTED) || (lexeme == BRACED))) {
976
977                /*
978                 * When this expression is destined to be compiled, and a
979                 * braced or quoted word within an expression is known at
980                 * compile time (no runtime substitutions in it), we can
981                 * store it as a literal rather than in its tokenized form.
982                 * This is an advantage since the compiled bytecode is going
983                 * to need the argument in Tcl_Obj form eventually, so it's
984                 * just as well to get there now.  Another advantage is that
985                 * with this conversion, larger constant expressions might
986                 * be grown and optimized.
987                 *
988                 * On the contrary, if the end goal of this parse is to
989                 * fill a Tcl_Parse for a caller of Tcl_ParseExpr(), then it's
990                 * wasteful to convert to a literal only to convert back again
991                 * later.
992                 */
993
994                literal = Tcl_NewObj();
995                if (TclWordKnownAtCompileTime(tokenPtr, literal)) {
996                    Tcl_ListObjAppendElement(NULL, litList, literal);
997                    complete = lastParsed = OT_LITERAL;
998                    parsePtr->numTokens = wordIndex;
999                    break;
1000                }
1001                Tcl_DecrRefCount(literal);
1002            }
1003            complete = lastParsed = OT_TOKENS;
1004            break;
1005        } /* case LEAF */
1006
1007        case UNARY:
1008
1009            /*
1010             * A unary operator appearing just after something that's not an
1011             * operator is a syntax error -- something trying to be the left
1012             * operand of an operator that doesn't take one.
1013             */
1014
1015            if (NotOperator(lastParsed)) {
1016                msg = Tcl_ObjPrintf("missing operator at %s", mark);
1017                scanned = 0;
1018                insertMark = 1;
1019                goto error;
1020            }
1021
1022            /* Create an OpNode for the unary operator */
1023            nodePtr->lexeme = lexeme;
1024            nodePtr->precedence = prec[lexeme];
1025            nodePtr->mark = MARK_RIGHT;
1026
1027            /*
1028             * A FUNCTION cannot be a constant expression, because Tcl allows
1029             * functions to return variable results with the same arguments;
1030             * for example, rand().  Other unary operators can root a constant
1031             * expression, so long as the argument is a constant expression.
1032             */
1033
1034            nodePtr->constant = (lexeme != FUNCTION);
1035
1036            /*
1037             * This unary operator is a new incomplete tree, so push it
1038             * onto our stack of incomplete trees.  Also remember it as
1039             * the last lexeme we parsed.
1040             */
1041
1042            nodePtr->p.prev = incomplete;
1043            incomplete = lastParsed = nodesUsed;
1044            nodesUsed++;
1045            break;
1046
1047        case BINARY: {
1048            OpNode *incompletePtr;
1049            unsigned char precedence = prec[lexeme];
1050
1051            /*
1052             * A binary operator appearing just after another operator is a
1053             * syntax error -- one of the two operators is missing an operand.
1054             */
1055
1056            if (IsOperator(lastParsed)) {
1057                if ((lexeme == CLOSE_PAREN)
1058                        && (nodePtr[-1].lexeme == OPEN_PAREN)) {
1059                    if (nodePtr[-2].lexeme == FUNCTION) {
1060
1061                        /*
1062                         * Normally, "()" is a syntax error, but as a special
1063                         * case accept it as an argument list for a function.
1064                         * Treat this as a special LEAF lexeme, and restart
1065                         * the parsing loop with zero characters scanned.
1066                         * We'll parse the ")" again the next time through,
1067                         * but with the OT_EMPTY leaf as the subexpression
1068                         * between the parens.
1069                         */
1070
1071                        scanned = 0;
1072                        complete = lastParsed = OT_EMPTY;
1073                        break;
1074                    }
1075                    msg = Tcl_ObjPrintf("empty subexpression at %s", mark);
1076                    scanned = 0;
1077                    insertMark = 1;
1078                    goto error;
1079                }
1080
1081                if (nodePtr[-1].precedence > precedence) {
1082                    if (nodePtr[-1].lexeme == OPEN_PAREN) {
1083                        TclNewLiteralStringObj(msg, "unbalanced open paren");
1084                        parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
1085                    } else if (nodePtr[-1].lexeme == COMMA) {
1086                        msg = Tcl_ObjPrintf(
1087                                "missing function argument at %s", mark);
1088                        scanned = 0;
1089                        insertMark = 1;
1090                    } else if (nodePtr[-1].lexeme == START) {
1091                        TclNewLiteralStringObj(msg, "empty expression");
1092                    }
1093                } else {
1094                    if (lexeme == CLOSE_PAREN) {
1095                        TclNewLiteralStringObj(msg, "unbalanced close paren");
1096                    } else if ((lexeme == COMMA)
1097                            && (nodePtr[-1].lexeme == OPEN_PAREN)
1098                            && (nodePtr[-2].lexeme == FUNCTION)) {
1099                        msg = Tcl_ObjPrintf(
1100                                "missing function argument at %s", mark);
1101                        scanned = 0;
1102                        insertMark = 1;
1103                    }
1104                }
1105                if (msg == NULL) {
1106                    msg = Tcl_ObjPrintf("missing operand at %s", mark);
1107                    scanned = 0;
1108                    insertMark = 1;
1109                }
1110                goto error;
1111            }
1112
1113            /*
1114             * Here is where the tree comes together.  At this point, we
1115             * have a stack of incomplete trees corresponding to
1116             * substrings that are incomplete expressions, followed by
1117             * a complete tree corresponding to a substring that is itself
1118             * a complete expression, followed by the binary operator we have
1119             * just parsed.  The incomplete trees can each be completed by
1120             * adding a right operand.
1121             *
1122             * To illustrate with an example, when we parse the expression
1123             * "1+2*3-4" and we reach this point having just parsed the "-"
1124             * operator, we have these incomplete trees: START, "1+", and
1125             * "2*".  Next we have the complete subexpression "3".  Last is
1126             * the "-" we've just parsed.
1127             *
1128             * The next step is to join our complete tree to an operator.
1129             * The choice is governed by the precedence and associativity
1130             * of the competing operators.  If we connect it as the right
1131             * operand of our most recent incomplete tree, we get a new
1132             * complete tree, and we can repeat the process.  The while
1133             * loop following repeats this until precedence indicates it
1134             * is time to join the complete tree as the left operand of
1135             * the just parsed binary operator.
1136             *
1137             * Continuing the example, the first pass through the loop
1138             * will join "3" to "2*"; the next pass will join "2*3" to
1139             * "1+".  Then we'll exit the loop and join "1+2*3" to "-".
1140             * When we return to parse another lexeme, our stack of
1141             * incomplete trees is START and "1+2*3-".
1142             */
1143
1144            while (1) {
1145                incompletePtr = nodes + incomplete;
1146
1147                if (incompletePtr->precedence < precedence) {
1148                    break;
1149                }
1150
1151                if (incompletePtr->precedence == precedence) {
1152
1153                    /* Right association rules for exponentiation. */
1154                    if (lexeme == EXPON) {
1155                        break;
1156                    }
1157
1158                    /*
1159                     * Special association rules for the conditional operators.
1160                     * The "?" and ":" operators have equal precedence, but
1161                     * must be linked up in sensible pairs.
1162                     */
1163
1164                    if ((incompletePtr->lexeme == QUESTION)
1165                            && (NotOperator(complete)
1166                            || (nodes[complete].lexeme != COLON))) {
1167                        break;
1168                    }
1169                    if ((incompletePtr->lexeme == COLON)
1170                            && (lexeme == QUESTION)) {
1171                        break;
1172                    }
1173                }
1174
1175                /* Some special syntax checks... */
1176
1177                /* Parens must balance */
1178                if ((incompletePtr->lexeme == OPEN_PAREN)
1179                        && (lexeme != CLOSE_PAREN)) {
1180                    TclNewLiteralStringObj(msg, "unbalanced open paren");
1181                    parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
1182                    goto error;
1183                }
1184
1185                /* Right operand of "?" must be ":" */
1186                if ((incompletePtr->lexeme == QUESTION)
1187                        && (NotOperator(complete)
1188                        || (nodes[complete].lexeme != COLON))) {
1189                    msg = Tcl_ObjPrintf(
1190                            "missing operator \":\" at %s", mark);
1191                    scanned = 0;
1192                    insertMark = 1;
1193                    goto error;
1194                }
1195
1196                /* Operator ":" may only be right operand of "?" */
1197                if (IsOperator(complete)
1198                        && (nodes[complete].lexeme == COLON)
1199                        && (incompletePtr->lexeme != QUESTION)) {
1200                    TclNewLiteralStringObj(msg,
1201                            "unexpected operator \":\" "
1202                            "without preceding \"?\"");
1203                    goto error;
1204                }
1205
1206                /*
1207                 * Attach complete tree as right operand of most recent
1208                 * incomplete tree.
1209                 */
1210
1211                incompletePtr->right = complete;
1212                if (IsOperator(complete)) {
1213                    nodes[complete].p.parent = incomplete;
1214                    incompletePtr->constant = incompletePtr->constant
1215                            && nodes[complete].constant;
1216                } else {
1217                    incompletePtr->constant = incompletePtr->constant
1218                            && (complete == OT_LITERAL);
1219                }
1220
1221                /*
1222                 * The QUESTION/COLON and FUNCTION/OPEN_PAREN combinations each
1223                 * make up a single operator.  Force them to agree whether they
1224                 * have a constant expression.
1225                 */
1226
1227                if ((incompletePtr->lexeme == QUESTION)
1228                        || (incompletePtr->lexeme == FUNCTION)) {
1229                    nodes[complete].constant = incompletePtr->constant;
1230                }
1231
1232                if (incompletePtr->lexeme == START) {
1233
1234                    /*
1235                     * Completing the START tree indicates we're done.
1236                     * Transfer the parse tree to the caller and return.
1237                     */
1238
1239                    *opTreePtr = nodes;
1240                    return TCL_OK;
1241                }
1242
1243                /*
1244                 * With a right operand attached, last incomplete tree has
1245                 * become the complete tree.  Pop it from the incomplete
1246                 * tree stack.
1247                 */
1248
1249                complete = incomplete;
1250                incomplete = incompletePtr->p.prev;
1251
1252                /* CLOSE_PAREN can only close one OPEN_PAREN. */
1253                if (incompletePtr->lexeme == OPEN_PAREN) {
1254                    break;
1255                }
1256            }
1257
1258            /* More syntax checks... */
1259
1260            /* Parens must balance. */
1261            if (lexeme == CLOSE_PAREN) {
1262                if (incompletePtr->lexeme != OPEN_PAREN) {
1263                    TclNewLiteralStringObj(msg, "unbalanced close paren");
1264                    goto error;
1265                }
1266            }
1267
1268            /* Commas must appear only in function argument lists. */
1269            if (lexeme == COMMA) {
1270                if  ((incompletePtr->lexeme != OPEN_PAREN)
1271                        || (incompletePtr[-1].lexeme != FUNCTION)) {
1272                    TclNewLiteralStringObj(msg,
1273                            "unexpected \",\" outside function argument list");
1274                    goto error;
1275                }
1276            }
1277
1278            /* Operator ":" may only be right operand of "?" */
1279            if (IsOperator(complete) && (nodes[complete].lexeme == COLON)) {
1280                TclNewLiteralStringObj(msg,
1281                        "unexpected operator \":\" without preceding \"?\"");
1282                goto error;
1283            }
1284
1285            /* Create no node for a CLOSE_PAREN lexeme. */
1286            if (lexeme == CLOSE_PAREN) {
1287                break;
1288            }
1289
1290            /* Link complete tree as left operand of new node. */
1291            nodePtr->lexeme = lexeme;
1292            nodePtr->precedence = precedence;
1293            nodePtr->mark = MARK_LEFT;
1294            nodePtr->left = complete;
1295
1296            /*
1297             * The COMMA operator cannot be optimized, since the function
1298             * needs all of its arguments, and optimization would reduce
1299             * the number.  Other binary operators root constant expressions
1300             * when both arguments are constant expressions.
1301             */
1302
1303            nodePtr->constant = (lexeme != COMMA);
1304
1305            if (IsOperator(complete)) {
1306                nodes[complete].p.parent = nodesUsed;
1307                nodePtr->constant = nodePtr->constant
1308                        && nodes[complete].constant;
1309            } else {
1310                nodePtr->constant = nodePtr->constant
1311                        && (complete == OT_LITERAL);
1312            }
1313
1314            /*
1315             * With a left operand attached and a right operand missing,
1316             * the just-parsed binary operator is root of a new incomplete
1317             * tree.  Push it onto the stack of incomplete trees.
1318             */
1319
1320            nodePtr->p.prev = incomplete;
1321            incomplete = lastParsed = nodesUsed;
1322            nodesUsed++;
1323            break;
1324        }       /* case BINARY */
1325        }       /* lexeme handler */
1326
1327        /* Advance past the just-parsed lexeme */
1328        start += scanned;
1329        numBytes -= scanned;
1330    }   /* main parsing loop */
1331
1332  error:
1333
1334    /*
1335     * We only get here if there's been an error.
1336     * Any errors that didn't get a suitable parsePtr->errorType,
1337     * get recorded as syntax errors.
1338     */
1339
1340    if (parsePtr->errorType == TCL_PARSE_SUCCESS) {
1341        parsePtr->errorType = TCL_PARSE_SYNTAX;
1342    }
1343
1344    /* Free any partial parse tree we've built. */
1345    if (nodes != NULL) {
1346        ckfree((char*) nodes);
1347    }
1348
1349    if (interp == NULL) {
1350
1351        /* Nowhere to report an error message, so just free it */
1352        if (msg) {
1353            Tcl_DecrRefCount(msg);
1354        }
1355    } else {
1356
1357        /*
1358         * Construct the complete error message.  Start with the simple
1359         * error message, pulled from the interp result if necessary...
1360         */
1361
1362        if (msg == NULL) {
1363            msg = Tcl_GetObjResult(interp);
1364        }
1365
1366        /*
1367         * Add a detailed quote from the bad expression, displaying and
1368         * sometimes marking the precise location of the syntax error.
1369         */
1370
1371        Tcl_AppendPrintfToObj(msg, "\nin expression \"%s%.*s%.*s%s%s%.*s%s\"",
1372                ((start - limit) < parsePtr->string) ? "" : "...",
1373                ((start - limit) < parsePtr->string)
1374                        ? (start - parsePtr->string) : limit - 3,
1375                ((start - limit) < parsePtr->string)
1376                        ? parsePtr->string : start - limit + 3,
1377                (scanned < limit) ? scanned : limit - 3, start,
1378                (scanned < limit) ? "" : "...", insertMark ? mark : "",
1379                (start + scanned + limit > parsePtr->end)
1380                        ? parsePtr->end - (start + scanned) : limit-3,
1381                start + scanned,
1382                (start + scanned + limit > parsePtr->end) ? "" : "...");
1383
1384        /* Next, append any postscript message. */
1385        if (post != NULL) {
1386            Tcl_AppendToObj(msg, ";\n", -1);
1387            Tcl_AppendObjToObj(msg, post);
1388            Tcl_DecrRefCount(post);
1389        }
1390        Tcl_SetObjResult(interp, msg);
1391
1392        /* Finally, place context information in the errorInfo. */
1393        numBytes = parsePtr->end - parsePtr->string;
1394        Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
1395                "\n    (parsing expression \"%.*s%s\")",
1396                (numBytes < limit) ? numBytes : limit - 3,
1397                parsePtr->string, (numBytes < limit) ? "" : "..."));
1398    }
1399
1400    return TCL_ERROR;
1401}
1402
1403/*
1404 *----------------------------------------------------------------------
1405 *
1406 * ConvertTreeToTokens --
1407 *
1408 *      Given a string, the numBytes bytes starting at start, and an OpNode
1409 *      tree and Tcl_Token array created by passing that same string to
1410 *      ParseExpr(), this function writes into *parsePtr the sequence of
1411 *      Tcl_Tokens needed so to satisfy the historical interface provided
1412 *      by Tcl_ParseExpr().  Note that this routine exists only for the sake
1413 *      of the public Tcl_ParseExpr() routine.  It is not used by Tcl itself
1414 *      at all.
1415 *
1416 * Results:
1417 *      None.
1418 *
1419 * Side effects:
1420 *      The Tcl_Parse *parsePtr is filled with Tcl_Tokens representing the
1421 *      parsed expression.
1422 *
1423 *----------------------------------------------------------------------
1424 */
1425
1426static void
1427ConvertTreeToTokens(
1428    const char *start,
1429    int numBytes,
1430    OpNode *nodes,
1431    Tcl_Token *tokenPtr,
1432    Tcl_Parse *parsePtr)
1433{
1434    int subExprTokenIdx = 0;
1435    OpNode *nodePtr = nodes;
1436    int next = nodePtr->right;
1437
1438    while (1) {
1439        Tcl_Token *subExprTokenPtr;
1440        int scanned, parentIdx;
1441        unsigned char lexeme;
1442
1443        /*
1444         * Advance the mark so the next exit from this node won't retrace
1445         * steps over ground already covered.
1446         */
1447
1448        nodePtr->mark++;
1449
1450        /* Handle next child node or leaf */
1451        switch (next) {
1452        case OT_EMPTY:
1453
1454            /* No tokens and no characters for the OT_EMPTY leaf. */
1455            break;
1456
1457        case OT_LITERAL:
1458
1459            /* Skip any white space that comes before the literal */
1460            scanned = TclParseAllWhiteSpace(start, numBytes);
1461            start +=scanned;
1462            numBytes -= scanned;
1463
1464            /* Reparse the literal to get pointers into source string */
1465            scanned = ParseLexeme(start, numBytes, &lexeme, NULL);
1466
1467            TclGrowParseTokenArray(parsePtr, 2);
1468            subExprTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens;
1469            subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR;
1470            subExprTokenPtr->start = start;
1471            subExprTokenPtr->size = scanned;
1472            subExprTokenPtr->numComponents = 1;
1473            subExprTokenPtr[1].type = TCL_TOKEN_TEXT;
1474            subExprTokenPtr[1].start = start;
1475            subExprTokenPtr[1].size = scanned;
1476            subExprTokenPtr[1].numComponents = 0;
1477
1478            parsePtr->numTokens += 2;
1479            start +=scanned;
1480            numBytes -= scanned;
1481            break;
1482
1483        case OT_TOKENS: {
1484
1485            /*
1486             * tokenPtr points to a token sequence that came from parsing
1487             * a Tcl word.  A Tcl word is made up of a sequence of one or
1488             * more elements.  When the word is only a single element, it's
1489             * been the historical practice to replace the TCL_TOKEN_WORD
1490             * token directly with a TCL_TOKEN_SUB_EXPR token.  However,
1491             * when the word has multiple elements, a TCL_TOKEN_WORD token
1492             * is kept as a grouping device so that TCL_TOKEN_SUB_EXPR
1493             * always has only one element.  Wise or not, these are the
1494             * rules the Tcl expr parser has followed, and for the sake
1495             * of those few callers of Tcl_ParseExpr() we do not change
1496             * them now.  Internally, we can do better.
1497             */
1498       
1499            int toCopy = tokenPtr->numComponents + 1;
1500
1501            if (tokenPtr->numComponents == tokenPtr[1].numComponents + 1) {
1502
1503                /*
1504                 * Single element word.  Copy tokens and convert the leading
1505                 * token to TCL_TOKEN_SUB_EXPR.
1506                 */
1507
1508                TclGrowParseTokenArray(parsePtr, toCopy);
1509                subExprTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens;
1510                memcpy(subExprTokenPtr, tokenPtr,
1511                        (size_t) toCopy * sizeof(Tcl_Token));
1512                subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR;
1513                parsePtr->numTokens += toCopy;
1514            } else {
1515
1516                /*
1517                 * Multiple element word.  Create a TCL_TOKEN_SUB_EXPR
1518                 * token to lead, with fields initialized from the leading
1519                 * token, then copy entire set of word tokens.
1520                 */
1521
1522                TclGrowParseTokenArray(parsePtr, toCopy+1);
1523                subExprTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens;
1524                *subExprTokenPtr = *tokenPtr;
1525                subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR;
1526                subExprTokenPtr->numComponents++;
1527                subExprTokenPtr++;
1528                memcpy(subExprTokenPtr, tokenPtr,
1529                        (size_t) toCopy * sizeof(Tcl_Token));
1530                parsePtr->numTokens += toCopy + 1;
1531            }
1532
1533            scanned = tokenPtr->start + tokenPtr->size - start;
1534            start +=scanned;
1535            numBytes -= scanned;
1536            tokenPtr += toCopy;
1537            break;
1538        }
1539
1540        default:
1541
1542            /* Advance to the child node, which is an operator. */
1543            nodePtr = nodes + next;
1544
1545            /* Skip any white space that comes before the subexpression */
1546            scanned = TclParseAllWhiteSpace(start, numBytes);
1547            start +=scanned;
1548            numBytes -= scanned;
1549
1550            /* Generate tokens for the operator / subexpression... */
1551            switch (nodePtr->lexeme) {
1552            case OPEN_PAREN:
1553            case COMMA:
1554            case COLON:
1555
1556                /*
1557                 * Historical practice has been to have no Tcl_Tokens for
1558                 * these operators.
1559                 */
1560
1561                break;
1562
1563            default: {
1564
1565                /*
1566                 * Remember the index of the last subexpression we were
1567                 * working on -- that of our parent.  We'll stack it later.
1568                 */
1569
1570                parentIdx = subExprTokenIdx;
1571
1572                /*
1573                 * Verify space for the two leading Tcl_Tokens representing
1574                 * the subexpression rooted by this operator.  The first
1575                 * Tcl_Token will be of type TCL_TOKEN_SUB_EXPR; the second
1576                 * of type TCL_TOKEN_OPERATOR.
1577                 */
1578
1579                TclGrowParseTokenArray(parsePtr, 2);
1580                subExprTokenIdx = parsePtr->numTokens;
1581                subExprTokenPtr = parsePtr->tokenPtr + subExprTokenIdx;
1582                parsePtr->numTokens += 2;
1583                subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR;
1584                subExprTokenPtr[1].type = TCL_TOKEN_OPERATOR;
1585
1586                /*
1587                 * Our current position scanning the string is the starting
1588                 * point for this subexpression.
1589                 */
1590
1591                subExprTokenPtr->start = start;
1592
1593                /*
1594                 * Eventually, we know that the numComponents field of the
1595                 * Tcl_Token of type TCL_TOKEN_OPERATOR will be 0.  This means
1596                 * we can make other use of this field for now to track the
1597                 * stack of subexpressions we have pending.
1598                 */
1599
1600                subExprTokenPtr[1].numComponents = parentIdx;
1601                break;
1602            }
1603            }
1604            break;
1605        }
1606
1607        /* Determine which way to exit the node on this pass. */
1608    router:
1609        switch (nodePtr->mark) {
1610        case MARK_LEFT:
1611            next = nodePtr->left;
1612            break;
1613
1614        case MARK_RIGHT:
1615            next = nodePtr->right;
1616
1617            /* Skip any white space that comes before the operator */
1618            scanned = TclParseAllWhiteSpace(start, numBytes);
1619            start +=scanned;
1620            numBytes -= scanned;
1621
1622            /*
1623             * Here we scan from the string the operator corresponding to
1624             * nodePtr->lexeme.
1625             */
1626
1627            scanned = ParseLexeme(start, numBytes, &lexeme, NULL);
1628
1629            switch(nodePtr->lexeme) {
1630            case OPEN_PAREN:
1631            case COMMA:
1632            case COLON:
1633
1634                /* No tokens for these lexemes -> nothing to do. */
1635                break;
1636
1637            default:
1638
1639                /*
1640                 * Record in the TCL_TOKEN_OPERATOR token the pointers into
1641                 * the string marking where the operator is.
1642                 */
1643
1644                subExprTokenPtr = parsePtr->tokenPtr + subExprTokenIdx;
1645                subExprTokenPtr[1].start = start;
1646                subExprTokenPtr[1].size = scanned;
1647                break;
1648            }
1649
1650            start +=scanned;
1651            numBytes -= scanned;
1652            break;
1653
1654        case MARK_PARENT:
1655            switch (nodePtr->lexeme) {
1656            case START:
1657
1658                /* When we get back to the START node, we're done. */
1659                return;
1660
1661            case COMMA:
1662            case COLON:
1663
1664                /* No tokens for these lexemes -> nothing to do. */
1665                break;
1666
1667            case OPEN_PAREN:
1668
1669                /* Skip past matching close paren. */
1670                scanned = TclParseAllWhiteSpace(start, numBytes);
1671                start +=scanned;
1672                numBytes -= scanned;
1673                scanned = ParseLexeme(start, numBytes, &lexeme, NULL);
1674                start +=scanned;
1675                numBytes -= scanned;
1676                break;
1677
1678            default: {
1679
1680                /*
1681                 * Before we leave this node/operator/subexpression for the
1682                 * last time, finish up its tokens....
1683                 *
1684                 * Our current position scanning the string is where the
1685                 * substring for the subexpression ends.
1686                 */
1687
1688                subExprTokenPtr = parsePtr->tokenPtr + subExprTokenIdx;
1689                subExprTokenPtr->size = start - subExprTokenPtr->start;
1690
1691                /*
1692                 * All the Tcl_Tokens allocated and filled belong to
1693                 * this subexpresion.  The first token is the leading
1694                 * TCL_TOKEN_SUB_EXPR token, and all the rest (one fewer)
1695                 * are its components.
1696                 */
1697
1698                subExprTokenPtr->numComponents =
1699                        (parsePtr->numTokens - subExprTokenIdx) - 1;
1700
1701                /*
1702                 * Finally, as we return up the tree to our parent, pop the
1703                 * parent subexpression off our subexpression stack, and
1704                 * fill in the zero numComponents for the operator Tcl_Token.
1705                 */
1706
1707                parentIdx = subExprTokenPtr[1].numComponents;
1708                subExprTokenPtr[1].numComponents = 0;
1709                subExprTokenIdx = parentIdx;
1710                break;
1711            }
1712            }
1713
1714            /* Since we're returning to parent, skip child handling code. */
1715            nodePtr = nodes + nodePtr->p.parent;
1716            goto router;
1717        }
1718    }
1719}
1720
1721/*
1722 *----------------------------------------------------------------------
1723 *
1724 * Tcl_ParseExpr --
1725 *
1726 *      Given a string, the numBytes bytes starting at start, this function
1727 *      parses it as a Tcl expression and stores information about the
1728 *      structure of the expression in the Tcl_Parse struct indicated by the
1729 *      caller.
1730 *
1731 * Results:
1732 *      If the string is successfully parsed as a valid Tcl expression, TCL_OK
1733 *      is returned, and data about the expression structure is written to
1734 *      *parsePtr. If the string cannot be parsed as a valid Tcl expression,
1735 *      TCL_ERROR is returned, and if interp is non-NULL, an error message is
1736 *      written to interp.
1737 *
1738 * Side effects:
1739 *      If there is insufficient space in parsePtr to hold all the information
1740 *      about the expression, then additional space is malloc-ed. If the
1741 *      function returns TCL_OK then the caller must eventually invoke
1742 *      Tcl_FreeParse to release any additional space that was allocated.
1743 *
1744 *----------------------------------------------------------------------
1745 */
1746
1747int
1748Tcl_ParseExpr(
1749    Tcl_Interp *interp,         /* Used for error reporting. */
1750    const char *start,          /* Start of source string to parse. */
1751    int numBytes,               /* Number of bytes in string. If < 0, the
1752                                 * string consists of all bytes up to the
1753                                 * first null character. */
1754    Tcl_Parse *parsePtr)        /* Structure to fill with information about
1755                                 * the parsed expression; any previous
1756                                 * information in the structure is ignored. */
1757{
1758    int code;
1759    OpNode *opTree = NULL;      /* Will point to the tree of operators */
1760    Tcl_Obj *litList = Tcl_NewObj();    /* List to hold the literals */
1761    Tcl_Obj *funcList = Tcl_NewObj();   /* List to hold the functon names*/
1762    Tcl_Parse *exprParsePtr =
1763            (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse));
1764                                /* Holds the Tcl_Tokens of substitutions */
1765
1766    if (numBytes < 0) {
1767        numBytes = (start ? strlen(start) : 0);
1768    }
1769
1770    code = ParseExpr(interp, start, numBytes, &opTree, litList,
1771            funcList, exprParsePtr, 1 /* parseOnly */);
1772    Tcl_DecrRefCount(funcList);
1773    Tcl_DecrRefCount(litList);
1774
1775    TclParseInit(interp, start, numBytes, parsePtr);
1776    if (code == TCL_OK) {
1777        ConvertTreeToTokens(start, numBytes,
1778                opTree, exprParsePtr->tokenPtr, parsePtr);
1779    } else {
1780        parsePtr->term = exprParsePtr->term;
1781        parsePtr->errorType = exprParsePtr->errorType;
1782    }
1783
1784    Tcl_FreeParse(exprParsePtr);
1785    TclStackFree(interp, exprParsePtr);
1786    ckfree((char *) opTree);
1787    return code;
1788}
1789
1790/*
1791 *----------------------------------------------------------------------
1792 *
1793 * ParseLexeme --
1794 *
1795 *      Parse a single lexeme from the start of a string, scanning no more
1796 *      than numBytes bytes.
1797 *
1798 * Results:
1799 *      Returns the number of bytes scanned to produce the lexeme.
1800 *
1801 * Side effects:
1802 *      Code identifying lexeme parsed is writen to *lexemePtr.
1803 *
1804 *----------------------------------------------------------------------
1805 */
1806
1807static int
1808ParseLexeme(
1809    const char *start,          /* Start of lexeme to parse. */
1810    int numBytes,               /* Number of bytes in string. */
1811    unsigned char *lexemePtr,   /* Write code of parsed lexeme to this
1812                                 * storage. */
1813    Tcl_Obj **literalPtr)       /* Write corresponding literal value to this
1814                                   storage, if non-NULL. */
1815{
1816    const char *end;
1817    int scanned;
1818    Tcl_UniChar ch;
1819    Tcl_Obj *literal = NULL;
1820    unsigned char byte;
1821
1822    if (numBytes == 0) {
1823        *lexemePtr = END;
1824        return 0;
1825    }
1826    byte = (unsigned char)(*start);
1827    if (byte < sizeof(Lexeme) && Lexeme[byte] != 0) {
1828        *lexemePtr = Lexeme[byte];
1829        return 1;
1830    }
1831    switch (byte) {
1832    case '*':
1833        if ((numBytes > 1) && (start[1] == '*')) {
1834            *lexemePtr = EXPON;
1835            return 2;
1836        }
1837        *lexemePtr = MULT;
1838        return 1;
1839
1840    case '=':
1841        if ((numBytes > 1) && (start[1] == '=')) {
1842            *lexemePtr = EQUAL;
1843            return 2;
1844        }
1845        *lexemePtr = INCOMPLETE;
1846        return 1;
1847
1848    case '!':
1849        if ((numBytes > 1) && (start[1] == '=')) {
1850            *lexemePtr = NEQ;
1851            return 2;
1852        }
1853        *lexemePtr = NOT;
1854        return 1;
1855
1856    case '&':
1857        if ((numBytes > 1) && (start[1] == '&')) {
1858            *lexemePtr = AND;
1859            return 2;
1860        }
1861        *lexemePtr = BIT_AND;
1862        return 1;
1863
1864    case '|':
1865        if ((numBytes > 1) && (start[1] == '|')) {
1866            *lexemePtr = OR;
1867            return 2;
1868        }
1869        *lexemePtr = BIT_OR;
1870        return 1;
1871
1872    case '<':
1873        if (numBytes > 1) {
1874            switch (start[1]) {
1875            case '<':
1876                *lexemePtr = LEFT_SHIFT;
1877                return 2;
1878            case '=':
1879                *lexemePtr = LEQ;
1880                return 2;
1881            }
1882        }
1883        *lexemePtr = LESS;
1884        return 1;
1885
1886    case '>':
1887        if (numBytes > 1) {
1888            switch (start[1]) {
1889            case '>':
1890                *lexemePtr = RIGHT_SHIFT;
1891                return 2;
1892            case '=':
1893                *lexemePtr = GEQ;
1894                return 2;
1895            }
1896        }
1897        *lexemePtr = GREATER;
1898        return 1;
1899
1900    case 'i':
1901        if ((numBytes > 1) && (start[1] == 'n')
1902                && ((numBytes == 2) || !isalpha(UCHAR(start[2])))) {
1903
1904            /*
1905             * Must make this check so we can tell the difference between
1906             * the "in" operator and the "int" function name and the
1907             * "infinity" numeric value.
1908             */
1909
1910            *lexemePtr = IN_LIST;
1911            return 2;
1912        }
1913        break;
1914
1915    case 'e':
1916        if ((numBytes > 1) && (start[1] == 'q')
1917                && ((numBytes == 2) || !isalpha(UCHAR(start[2])))) {
1918            *lexemePtr = STREQ;
1919            return 2;
1920        }
1921        break;
1922
1923    case 'n':
1924        if ((numBytes > 1) && ((numBytes == 2) || !isalpha(UCHAR(start[2])))) {
1925            switch (start[1]) {
1926            case 'e':
1927                *lexemePtr = STRNEQ;
1928                return 2;
1929            case 'i':
1930                *lexemePtr = NOT_IN_LIST;
1931                return 2;
1932            }
1933        }
1934    }
1935
1936    literal = Tcl_NewObj();
1937    if (TclParseNumber(NULL, literal, NULL, start, numBytes, &end,
1938            TCL_PARSE_NO_WHITESPACE) == TCL_OK) {
1939        TclInitStringRep(literal, start, end-start);
1940        *lexemePtr = NUMBER;
1941        if (literalPtr) {
1942            *literalPtr = literal;
1943        } else {
1944            Tcl_DecrRefCount(literal);
1945        }
1946        return (end-start);
1947    }
1948
1949    if (Tcl_UtfCharComplete(start, numBytes)) {
1950        scanned = Tcl_UtfToUniChar(start, &ch);
1951    } else {
1952        char utfBytes[TCL_UTF_MAX];
1953        memcpy(utfBytes, start, (size_t) numBytes);
1954        utfBytes[numBytes] = '\0';
1955        scanned = Tcl_UtfToUniChar(utfBytes, &ch);
1956    }
1957    if (!isalpha(UCHAR(ch))) {
1958        *lexemePtr = INVALID;
1959        Tcl_DecrRefCount(literal);
1960        return scanned;
1961    }
1962    end = start;
1963    while (isalnum(UCHAR(ch)) || (UCHAR(ch) == '_')) {
1964        end += scanned;
1965        numBytes -= scanned;
1966        if (Tcl_UtfCharComplete(end, numBytes)) {
1967            scanned = Tcl_UtfToUniChar(end, &ch);
1968        } else {
1969            char utfBytes[TCL_UTF_MAX];
1970            memcpy(utfBytes, end, (size_t) numBytes);
1971            utfBytes[numBytes] = '\0';
1972            scanned = Tcl_UtfToUniChar(utfBytes, &ch);
1973        }
1974    }
1975    *lexemePtr = BAREWORD;
1976    if (literalPtr) {
1977        Tcl_SetStringObj(literal, start, (int) (end-start));
1978        *literalPtr = literal;
1979    } else {
1980        Tcl_DecrRefCount(literal);
1981    }
1982    return (end-start);
1983}
1984
1985/*
1986 *----------------------------------------------------------------------
1987 *
1988 * TclCompileExpr --
1989 *
1990 *      This procedure compiles a string containing a Tcl expression into Tcl
1991 *      bytecodes.
1992 *
1993 * Results:
1994 *      None.
1995 *
1996 * Side effects:
1997 *      Adds instructions to envPtr to evaluate the expression at runtime.
1998 *
1999 *----------------------------------------------------------------------
2000 */
2001
2002void
2003TclCompileExpr(
2004    Tcl_Interp *interp,         /* Used for error reporting. */
2005    const char *script,         /* The source script to compile. */
2006    int numBytes,               /* Number of bytes in script. */
2007    CompileEnv *envPtr,         /* Holds resulting instructions. */
2008    int optimize)               /* 0 for one-off expressions */
2009{
2010    OpNode *opTree = NULL;      /* Will point to the tree of operators */
2011    Tcl_Obj *litList = Tcl_NewObj();    /* List to hold the literals */
2012    Tcl_Obj *funcList = Tcl_NewObj();   /* List to hold the functon names*/
2013    Tcl_Parse *parsePtr =
2014            (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse));
2015                                /* Holds the Tcl_Tokens of substitutions */
2016
2017    int code = ParseExpr(interp, script, numBytes, &opTree, litList,
2018            funcList, parsePtr, 0 /* parseOnly */);
2019
2020    if (code == TCL_OK) {
2021
2022        /* Valid parse; compile the tree. */
2023        int objc;
2024        Tcl_Obj *const *litObjv;
2025        Tcl_Obj **funcObjv;
2026
2027        /* TIP #280 : Track Lines within the expression */
2028        TclAdvanceLines(&envPtr->line, script,
2029                script + TclParseAllWhiteSpace(script, numBytes));
2030
2031        TclListObjGetElements(NULL, litList, &objc, (Tcl_Obj ***)&litObjv);
2032        TclListObjGetElements(NULL, funcList, &objc, &funcObjv);
2033        CompileExprTree(interp, opTree, 0, &litObjv, funcObjv,
2034                parsePtr->tokenPtr, envPtr, optimize);
2035    } else {
2036        TclCompileSyntaxError(interp, envPtr);
2037    }
2038
2039    Tcl_FreeParse(parsePtr);
2040    TclStackFree(interp, parsePtr);
2041    Tcl_DecrRefCount(funcList);
2042    Tcl_DecrRefCount(litList);
2043    ckfree((char *) opTree);
2044}
2045
2046/*
2047 *----------------------------------------------------------------------
2048 *
2049 * ExecConstantExprTree --
2050 *      Compiles and executes bytecode for the subexpression tree at index
2051 *      in the nodes array.  This subexpression must be constant, made up
2052 *      of only constant operators (not functions) and literals.
2053 *
2054 * Results:
2055 *      A standard Tcl return code and result left in interp.
2056 *
2057 * Side effects:
2058 *      Consumes subtree of nodes rooted at index.  Advances the pointer
2059 *      *litObjvPtr.
2060 *
2061 *----------------------------------------------------------------------
2062 */
2063
2064static int
2065ExecConstantExprTree(
2066    Tcl_Interp *interp,
2067    OpNode *nodes,
2068    int index,
2069    Tcl_Obj *const **litObjvPtr)
2070{
2071    CompileEnv *envPtr;
2072    ByteCode *byteCodePtr;
2073    int code;
2074    Tcl_Obj *byteCodeObj = Tcl_NewObj();
2075
2076    /*
2077     * Note we are compiling an expression with literal arguments. This means
2078     * there can be no [info frame] calls when we execute the resulting
2079     * bytecode, so there's no need to tend to TIP 280 issues.
2080     */
2081
2082    envPtr = (CompileEnv *) TclStackAlloc(interp, sizeof(CompileEnv));
2083    TclInitCompileEnv(interp, envPtr, NULL, 0, NULL, 0);
2084    CompileExprTree(interp, nodes, index, litObjvPtr, NULL, NULL, envPtr,
2085            0 /* optimize */);
2086    TclEmitOpcode(INST_DONE, envPtr);
2087    Tcl_IncrRefCount(byteCodeObj);
2088    TclInitByteCodeObj(byteCodeObj, envPtr);
2089    TclFreeCompileEnv(envPtr);
2090    TclStackFree(interp, envPtr);
2091    byteCodePtr = (ByteCode *) byteCodeObj->internalRep.otherValuePtr;
2092    code = TclExecuteByteCode(interp, byteCodePtr);
2093    Tcl_DecrRefCount(byteCodeObj);
2094    return code;
2095}
2096
2097/*
2098 *----------------------------------------------------------------------
2099 *
2100 * CompileExprTree --
2101 *      Compiles and writes to envPtr instructions for the subexpression
2102 *      tree at index in the nodes array.  (*litObjvPtr) must point to the
2103 *      proper location in a corresponding literals list.  Likewise, when
2104 *      non-NULL, funcObjv and tokenPtr must point into matching arrays of
2105 *      function names and Tcl_Token's derived from earlier call to
2106 *      ParseExpr().  When optimize is true, any constant subexpressions
2107 *      will be precomputed.
2108 *
2109 * Results:
2110 *      None.
2111 *
2112 * Side effects:
2113 *      Adds instructions to envPtr to evaluate the expression at runtime.
2114 *      Consumes subtree of nodes rooted at index.  Advances the pointer
2115 *      *litObjvPtr.
2116 *
2117 *----------------------------------------------------------------------
2118 */
2119
2120static void
2121CompileExprTree(
2122    Tcl_Interp *interp,
2123    OpNode *nodes,
2124    int index,
2125    Tcl_Obj *const **litObjvPtr,
2126    Tcl_Obj *const *funcObjv,
2127    Tcl_Token *tokenPtr,
2128    CompileEnv *envPtr,
2129    int optimize)
2130{
2131    OpNode *nodePtr = nodes + index;
2132    OpNode *rootPtr = nodePtr;
2133    int numWords = 0;
2134    JumpList *jumpPtr = NULL;
2135    int convert = 1;
2136
2137    while (1) {
2138        int next;
2139        JumpList *freePtr, *newJump;
2140
2141        if (nodePtr->mark == MARK_LEFT) {
2142            next = nodePtr->left;
2143
2144            switch (nodePtr->lexeme) {
2145            case QUESTION:
2146                newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList));
2147                newJump->next = jumpPtr;
2148                jumpPtr = newJump;
2149                newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList));
2150                newJump->next = jumpPtr;
2151                jumpPtr = newJump;
2152                jumpPtr->depth = envPtr->currStackDepth;
2153                convert = 1;
2154                break;
2155            case AND:
2156            case OR:
2157                newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList));
2158                newJump->next = jumpPtr;
2159                jumpPtr = newJump;
2160                newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList));
2161                newJump->next = jumpPtr;
2162                jumpPtr = newJump;
2163                newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList));
2164                newJump->next = jumpPtr;
2165                jumpPtr = newJump;
2166                jumpPtr->depth = envPtr->currStackDepth;
2167                break;
2168            }
2169        } else if (nodePtr->mark == MARK_RIGHT) {
2170            next = nodePtr->right;
2171
2172            switch (nodePtr->lexeme) {
2173            case FUNCTION: {
2174                Tcl_DString cmdName;
2175                const char *p;
2176                int length;
2177
2178                Tcl_DStringInit(&cmdName);
2179                Tcl_DStringAppend(&cmdName, "tcl::mathfunc::", -1);
2180                p = TclGetStringFromObj(*funcObjv, &length);
2181                funcObjv++;
2182                Tcl_DStringAppend(&cmdName, p, length);
2183                TclEmitPush(TclRegisterNewNSLiteral(envPtr,
2184                        Tcl_DStringValue(&cmdName),
2185                        Tcl_DStringLength(&cmdName)), envPtr);
2186                Tcl_DStringFree(&cmdName);
2187
2188                /*
2189                 * Start a count of the number of words in this function
2190                 * command invocation.  In case there's already a count
2191                 * in progress (nested functions), save it in our unused
2192                 * "left" field for restoring later.
2193                 */
2194
2195                nodePtr->left = numWords;
2196                numWords = 2;   /* Command plus one argument */
2197                break;
2198            }
2199            case QUESTION:
2200                TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &(jumpPtr->jump));
2201                break;
2202            case COLON:
2203                TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
2204                        &(jumpPtr->next->jump));
2205                envPtr->currStackDepth = jumpPtr->depth;
2206                jumpPtr->offset = (envPtr->codeNext - envPtr->codeStart);
2207                jumpPtr->convert = convert;
2208                convert = 1;
2209                break;
2210            case AND:
2211                TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &(jumpPtr->jump));
2212                break;
2213            case OR:
2214                TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &(jumpPtr->jump));
2215                break;
2216            }
2217        } else {
2218            switch (nodePtr->lexeme) {
2219            case START:
2220            case QUESTION:
2221                if (convert && (nodePtr == rootPtr)) {
2222                    TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
2223                }
2224                break;
2225            case OPEN_PAREN:
2226
2227                /* do nothing */
2228                break;
2229            case FUNCTION:
2230
2231                /*
2232                 * Use the numWords count we've kept to invoke the
2233                 * function command with the correct number of arguments.
2234                 */
2235               
2236                if (numWords < 255) {
2237                    TclEmitInstInt1(INST_INVOKE_STK1, numWords, envPtr);
2238                } else {
2239                    TclEmitInstInt4(INST_INVOKE_STK4, numWords, envPtr);
2240                }
2241
2242                /* Restore any saved numWords value. */
2243                numWords = nodePtr->left;
2244                convert = 1;
2245                break;
2246            case COMMA:
2247
2248                /* Each comma implies another function argument. */
2249                numWords++;
2250                break;
2251            case COLON:
2252                if (TclFixupForwardJump(envPtr, &(jumpPtr->next->jump),
2253                        (envPtr->codeNext - envPtr->codeStart)
2254                        - jumpPtr->next->jump.codeOffset, 127)) {
2255                    jumpPtr->offset += 3;
2256                }
2257                TclFixupForwardJump(envPtr, &(jumpPtr->jump),
2258                        jumpPtr->offset - jumpPtr->jump.codeOffset, 127);
2259                convert |= jumpPtr->convert;
2260                envPtr->currStackDepth = jumpPtr->depth + 1;
2261                freePtr = jumpPtr;
2262                jumpPtr = jumpPtr->next;
2263                TclStackFree(interp, freePtr);
2264                freePtr = jumpPtr;
2265                jumpPtr = jumpPtr->next;
2266                TclStackFree(interp, freePtr);
2267                break;
2268            case AND:
2269            case OR:
2270                TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND)
2271                        ?  TCL_FALSE_JUMP : TCL_TRUE_JUMP,
2272                        &(jumpPtr->next->jump));
2273                TclEmitPush(TclRegisterNewLiteral(envPtr,
2274                        (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr);
2275                TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
2276                        &(jumpPtr->next->next->jump));
2277                TclFixupForwardJumpToHere(envPtr, &(jumpPtr->next->jump), 127);
2278                if (TclFixupForwardJumpToHere(envPtr, &(jumpPtr->jump), 127)) {
2279                    jumpPtr->next->next->jump.codeOffset += 3;
2280                }
2281                TclEmitPush(TclRegisterNewLiteral(envPtr,
2282                        (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr);
2283                TclFixupForwardJumpToHere(envPtr, &(jumpPtr->next->next->jump),
2284                        127);
2285                convert = 0;
2286                envPtr->currStackDepth = jumpPtr->depth + 1;
2287                freePtr = jumpPtr;
2288                jumpPtr = jumpPtr->next;
2289                TclStackFree(interp, freePtr);
2290                freePtr = jumpPtr;
2291                jumpPtr = jumpPtr->next;
2292                TclStackFree(interp, freePtr);
2293                freePtr = jumpPtr;
2294                jumpPtr = jumpPtr->next;
2295                TclStackFree(interp, freePtr);
2296                break;
2297            default:
2298                TclEmitOpcode(instruction[nodePtr->lexeme], envPtr);
2299                convert = 0;
2300                break;
2301            }
2302            if (nodePtr == rootPtr) {
2303
2304                /* We're done */
2305                return;
2306            }
2307            nodePtr = nodes + nodePtr->p.parent;
2308            continue;
2309        }
2310
2311        nodePtr->mark++;
2312        switch (next) {
2313        case OT_EMPTY:
2314            numWords = 1;       /* No arguments, so just the command */
2315            break;
2316        case OT_LITERAL: {
2317            Tcl_Obj *const *litObjv = *litObjvPtr;
2318            Tcl_Obj *literal = *litObjv;
2319
2320            if (optimize) {
2321                int length, index;
2322                const char *bytes = TclGetStringFromObj(literal, &length);
2323                LiteralEntry *lePtr;
2324                Tcl_Obj *objPtr;
2325
2326                index = TclRegisterNewLiteral(envPtr, bytes, length);
2327                lePtr = envPtr->literalArrayPtr + index;
2328                objPtr = lePtr->objPtr;
2329                if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) {
2330                    /*
2331                     * Would like to do this:
2332                     *
2333                     * lePtr->objPtr = literal;
2334                     * Tcl_IncrRefCount(literal);
2335                     * Tcl_DecrRefCount(objPtr);
2336                     *
2337                     * However, the design of the "global" and "local"
2338                     * LiteralTable does not permit the value of lePtr->objPtr
2339                     * to change.  So rather than replace lePtr->objPtr, we
2340                     * do surgery to transfer our desired intrep into it.
2341                     *
2342                     */
2343                    objPtr->typePtr = literal->typePtr;
2344                    objPtr->internalRep = literal->internalRep;
2345                    literal->typePtr = NULL;
2346                }
2347                TclEmitPush(index, envPtr);
2348            } else {
2349                /*
2350                 * When optimize==0, we know the expression is a one-off
2351                 * and there's nothing to be gained from sharing literals
2352                 * when they won't live long, and the copies we have already
2353                 * have an appropriate intrep.  In this case, skip literal
2354                 * registration that would enable sharing, and use the routine
2355                 * that preserves intreps.
2356                 */
2357                TclEmitPush(TclAddLiteralObj(envPtr, literal, NULL), envPtr);
2358            }
2359            (*litObjvPtr)++;
2360            break;
2361        }
2362        case OT_TOKENS:
2363            TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents,
2364                    envPtr);
2365            tokenPtr += tokenPtr->numComponents + 1;
2366            break;
2367        default:
2368            if (optimize && nodes[next].constant) {
2369                Tcl_InterpState save = Tcl_SaveInterpState(interp, TCL_OK);
2370                if (ExecConstantExprTree(interp, nodes, next, litObjvPtr)
2371                        == TCL_OK) {
2372                    TclEmitPush(TclAddLiteralObj(envPtr,
2373                            Tcl_GetObjResult(interp), NULL), envPtr);
2374                } else {
2375                    TclCompileSyntaxError(interp, envPtr);
2376                }
2377                Tcl_RestoreInterpState(interp, save);
2378                convert = 0;
2379            } else {
2380                nodePtr = nodes + next;
2381            }
2382        }
2383    }
2384}
2385
2386/*
2387 *----------------------------------------------------------------------
2388 *
2389 * TclSingleOpCmd --
2390 *      Implements the commands: ~, !, <<, >>, %, !=, ne, in, ni
2391 *      in the ::tcl::mathop namespace.  These commands have no
2392 *      extension to arbitrary arguments; they accept only exactly one
2393 *      or exactly two arguments as suitable for the operator.
2394 *
2395 * Results:
2396 *      A standard Tcl return code and result left in interp.
2397 *
2398 * Side effects:
2399 *      None.
2400 *
2401 *----------------------------------------------------------------------
2402 */
2403
2404int
2405TclSingleOpCmd(
2406    ClientData clientData,
2407    Tcl_Interp *interp,
2408    int objc,
2409    Tcl_Obj *const objv[])
2410{
2411    TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
2412    unsigned char lexeme;
2413    OpNode nodes[2];
2414    Tcl_Obj *const *litObjv = objv + 1;
2415
2416    if (objc != 1+occdPtr->i.numArgs) {
2417        Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected);
2418        return TCL_ERROR;
2419    }
2420
2421    ParseLexeme(occdPtr->op, strlen(occdPtr->op), &lexeme, NULL);
2422    nodes[0].lexeme = START;
2423    nodes[0].mark = MARK_RIGHT;
2424    nodes[0].right = 1;
2425    nodes[1].lexeme = lexeme;
2426    if (objc == 2) {
2427        nodes[1].mark = MARK_RIGHT;
2428    } else {
2429        nodes[1].mark = MARK_LEFT;
2430        nodes[1].left = OT_LITERAL;
2431    }
2432    nodes[1].right = OT_LITERAL;
2433    nodes[1].p.parent = 0;
2434
2435    return ExecConstantExprTree(interp, nodes, 0, &litObjv);
2436}
2437
2438/*
2439 *----------------------------------------------------------------------
2440 *
2441 * TclSortingOpCmd --
2442 *      Implements the commands: <, <=, >, >=, ==, eq
2443 *      in the ::tcl::mathop namespace.  These commands are defined for
2444 *      arbitrary number of arguments by computing the AND of the base
2445 *      operator applied to all neighbor argument pairs.
2446 *
2447 * Results:
2448 *      A standard Tcl return code and result left in interp.
2449 *
2450 * Side effects:
2451 *      None.
2452 *
2453 *----------------------------------------------------------------------
2454 */
2455
2456int
2457TclSortingOpCmd(
2458    ClientData clientData,
2459    Tcl_Interp *interp,
2460    int objc,
2461    Tcl_Obj *const objv[])
2462{
2463    int code = TCL_OK;
2464
2465    if (objc < 3) {
2466        Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1));
2467    } else {
2468        TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
2469        Tcl_Obj **litObjv = (Tcl_Obj **) TclStackAlloc(interp,
2470                2*(objc-2)*sizeof(Tcl_Obj *));
2471        OpNode *nodes = (OpNode *) TclStackAlloc(interp,
2472                2*(objc-2)*sizeof(OpNode));
2473        unsigned char lexeme;
2474        int i, lastAnd = 1;
2475        Tcl_Obj *const *litObjPtrPtr = litObjv;
2476
2477        ParseLexeme(occdPtr->op, strlen(occdPtr->op), &lexeme, NULL);
2478
2479        litObjv[0] = objv[1];
2480        nodes[0].lexeme = START;
2481        nodes[0].mark = MARK_RIGHT;
2482        for (i=2; i<objc-1; i++) {
2483            litObjv[2*(i-1)-1] = objv[i];
2484            nodes[2*(i-1)-1].lexeme = lexeme;
2485            nodes[2*(i-1)-1].mark = MARK_LEFT;
2486            nodes[2*(i-1)-1].left = OT_LITERAL;
2487            nodes[2*(i-1)-1].right = OT_LITERAL;
2488
2489            litObjv[2*(i-1)] = objv[i];
2490            nodes[2*(i-1)].lexeme = AND;
2491            nodes[2*(i-1)].mark = MARK_LEFT;
2492            nodes[2*(i-1)].left = lastAnd;
2493            nodes[lastAnd].p.parent = 2*(i-1);
2494
2495            nodes[2*(i-1)].right = 2*(i-1)+1;
2496            nodes[2*(i-1)+1].p.parent= 2*(i-1);
2497
2498            lastAnd = 2*(i-1);
2499        }
2500        litObjv[2*(objc-2)-1] = objv[objc-1];
2501
2502        nodes[2*(objc-2)-1].lexeme = lexeme;
2503        nodes[2*(objc-2)-1].mark = MARK_LEFT;
2504        nodes[2*(objc-2)-1].left = OT_LITERAL;
2505        nodes[2*(objc-2)-1].right = OT_LITERAL;
2506
2507        nodes[0].right = lastAnd;
2508        nodes[lastAnd].p.parent = 0;
2509
2510        code = ExecConstantExprTree(interp, nodes, 0, &litObjPtrPtr);
2511
2512        TclStackFree(interp, nodes);
2513        TclStackFree(interp, litObjv);
2514    }
2515    return code;
2516}
2517
2518/*
2519 *----------------------------------------------------------------------
2520 *
2521 * TclVariadicOpCmd --
2522 *      Implements the commands: +, *, &, |, ^, **
2523 *      in the ::tcl::mathop namespace.  These commands are defined for
2524 *      arbitrary number of arguments by repeatedly applying the base
2525 *      operator with suitable associative rules.  When fewer than two
2526 *      arguments are provided, suitable identity values are returned.
2527 *
2528 * Results:
2529 *      A standard Tcl return code and result left in interp.
2530 *
2531 * Side effects:
2532 *      None.
2533 *
2534 *----------------------------------------------------------------------
2535 */
2536
2537int
2538TclVariadicOpCmd(
2539    ClientData clientData,
2540    Tcl_Interp *interp,
2541    int objc,
2542    Tcl_Obj *const objv[])
2543{
2544    TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
2545    unsigned char lexeme;
2546    int code;
2547
2548    if (objc < 2) {
2549        Tcl_SetObjResult(interp, Tcl_NewIntObj(occdPtr->i.identity));
2550        return TCL_OK;
2551    }
2552
2553    ParseLexeme(occdPtr->op, strlen(occdPtr->op), &lexeme, NULL);
2554    lexeme |= BINARY;
2555
2556    if (objc == 2) {
2557        Tcl_Obj *litObjv[2];
2558        OpNode nodes[2];
2559        int decrMe = 0;
2560        Tcl_Obj *const *litObjPtrPtr = litObjv;
2561
2562        if (lexeme == EXPON) {
2563            litObjv[1] = Tcl_NewIntObj(occdPtr->i.identity);
2564            Tcl_IncrRefCount(litObjv[1]);
2565            decrMe = 1;
2566            litObjv[0] = objv[1];
2567            nodes[0].lexeme = START;
2568            nodes[0].mark = MARK_RIGHT;
2569            nodes[0].right = 1;
2570            nodes[1].lexeme = lexeme;
2571            nodes[1].mark = MARK_LEFT;
2572            nodes[1].left = OT_LITERAL;
2573            nodes[1].right = OT_LITERAL;
2574            nodes[1].p.parent = 0;
2575        } else {
2576            if (lexeme == DIVIDE) {
2577                litObjv[0] = Tcl_NewDoubleObj(1.0);
2578            } else {
2579                litObjv[0] = Tcl_NewIntObj(occdPtr->i.identity);
2580            }
2581            Tcl_IncrRefCount(litObjv[0]);
2582            litObjv[1] = objv[1];
2583            nodes[0].lexeme = START;
2584            nodes[0].mark = MARK_RIGHT;
2585            nodes[0].right = 1;
2586            nodes[1].lexeme = lexeme;
2587            nodes[1].mark = MARK_LEFT;
2588            nodes[1].left = OT_LITERAL;
2589            nodes[1].right = OT_LITERAL;
2590            nodes[1].p.parent = 0;
2591        }
2592
2593        code = ExecConstantExprTree(interp, nodes, 0, &litObjPtrPtr);
2594
2595        Tcl_DecrRefCount(litObjv[decrMe]);
2596        return code;
2597    } else {
2598        Tcl_Obj *const *litObjv = objv + 1;
2599        OpNode *nodes = (OpNode *) TclStackAlloc(interp,
2600                (objc-1)*sizeof(OpNode));
2601        int i, lastOp = OT_LITERAL;
2602
2603        nodes[0].lexeme = START;
2604        nodes[0].mark = MARK_RIGHT;
2605        if (lexeme == EXPON) {
2606            for (i=objc-2; i>0; i-- ) {
2607                nodes[i].lexeme = lexeme;
2608                nodes[i].mark = MARK_LEFT;
2609                nodes[i].left = OT_LITERAL;
2610                nodes[i].right = lastOp;
2611                if (lastOp >= 0) {
2612                    nodes[lastOp].p.parent = i;
2613                }
2614                lastOp = i;
2615            }
2616        } else {
2617            for (i=1; i<objc-1; i++ ) {
2618                nodes[i].lexeme = lexeme;
2619                nodes[i].mark = MARK_LEFT;
2620                nodes[i].left = lastOp;
2621                if (lastOp >= 0) {
2622                    nodes[lastOp].p.parent = i;
2623                }
2624                nodes[i].right = OT_LITERAL;
2625                lastOp = i;
2626            }
2627        }
2628        nodes[0].right = lastOp;
2629        nodes[lastOp].p.parent = 0;
2630
2631        code = ExecConstantExprTree(interp, nodes, 0, &litObjv);
2632
2633        TclStackFree(interp, nodes);
2634
2635        return code;
2636    }
2637}
2638
2639/*
2640 *----------------------------------------------------------------------
2641 *
2642 * TclNoIdentOpCmd --
2643 *      Implements the commands: -, /
2644 *      in the ::tcl::mathop namespace.  These commands are defined for
2645 *      arbitrary non-zero number of arguments by repeatedly applying
2646 *      the base operator with suitable associative rules.  When no
2647 *      arguments are provided, an error is raised.
2648 *
2649 * Results:
2650 *      A standard Tcl return code and result left in interp.
2651 *
2652 * Side effects:
2653 *      None.
2654 *
2655 *----------------------------------------------------------------------
2656 */
2657
2658int
2659TclNoIdentOpCmd(
2660    ClientData clientData,
2661    Tcl_Interp *interp,
2662    int objc,
2663    Tcl_Obj *const objv[])
2664{
2665    TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
2666    if (objc < 2) {
2667        Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected);
2668        return TCL_ERROR;
2669    }
2670    return TclVariadicOpCmd(clientData, interp, objc, objv);
2671}
2672/*
2673 * Local Variables:
2674 * mode: c
2675 * c-basic-offset: 4
2676 * fill-column: 78
2677 * End:
2678 */
Note: See TracBrowser for help on using the repository browser.