Planet

navi

home

PPS

about

screenshots

download

development

forum

Context Navigation

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

Last change on this file since 35 was 25, checked in by landauf, 18 years ago
added tcl to libs
File size: 80.2 KB

Rev	Line
[25]	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
	27	typedef 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
	65	enum 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
	111	enum 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
	305	enum 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
	332	static 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
	387	static 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
	443	static 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
	493	typedef 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
	511	static 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);
	515	static void ConvertTreeToTokens(const char *start, int numBytes,
	516	OpNode nodes, Tcl_Token tokenPtr,
	517	Tcl_Parse *parsePtr);
	518	static int ExecConstantExprTree(Tcl_Interp interp, OpNode nodes,
	519	int index, Tcl_Obj * const **litObjvPtr);
	520	static 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);
	524	static 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
	559	static int
	560	ParseExpr(
	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 "23" 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
	1426	static void
	1427	ConvertTreeToTokens(
	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
	1747	int
	1748	Tcl_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
	1807	static int
	1808	ParseLexeme(
	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
	2002	void
	2003	TclCompileExpr(
	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
	2064	static int
	2065	ExecConstantExprTree(
	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
	2120	static void
	2121	CompileExprTree(
	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
	2404	int
	2405	TclSingleOpCmd(
	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
	2456	int
	2457	TclSortingOpCmd(
	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
	2537	int
	2538	TclVariadicOpCmd(
	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
	2658	int
	2659	TclNoIdentOpCmd(
	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.

Download in other formats: