summaryrefslogtreecommitdiffstats
path: root/generic/tclCompExpr.c
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2006-11-09 16:52:25 (GMT)
committerdgp <dgp@users.sourceforge.net>2006-11-09 16:52:25 (GMT)
commitc7f945aac52601074c20727c95a1f548ed743a98 (patch)
treedfefc1722356d87fe272ed914076059ca241b48a /generic/tclCompExpr.c
parent50372ddbf9e9b93ddf9b64cad6b9380d5a542c2d (diff)
downloadtcl-c7f945aac52601074c20727c95a1f548ed743a98.zip
tcl-c7f945aac52601074c20727c95a1f548ed743a98.tar.gz
tcl-c7f945aac52601074c20727c95a1f548ed743a98.tar.bz2
* generic/tclParseExpr.c (removed): Moved all the code of
* generic/tclCompExpr.c: tclParseExpr.c into tclCompExpr.c. * unix/Makefile.in: This sets the stage for expr compiling to * win/Makefile.in: work directly with the full parse tree * win/makefile.bc: structures, and not have to pass through * win/makefile.vc: the information lossy format of an array * win/tcl.dsp: of Tcl_Tokens.
Diffstat (limited to 'generic/tclCompExpr.c')
-rw-r--r--generic/tclCompExpr.c1052
1 files changed, 1051 insertions, 1 deletions
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index 63d8be3..c4d2829 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -5,17 +5,1067 @@
*
* Copyright (c) 1997 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 by Scriptics Corporation.
+ * Contributions from Don Porter, NIST, 2006. (not subject to US copyright)
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompExpr.c,v 1.34 2006/09/05 02:44:38 dgp Exp $
+ * RCS: @(#) $Id: tclCompExpr.c,v 1.35 2006/11/09 16:52:30 dgp Exp $
*/
#include "tclInt.h"
#include "tclCompile.h"
/*
+ * The ExprNode structure represents one node of the parse tree produced
+ * as an interim structure by the expression parser.
+ */
+
+typedef struct ExprNode {
+ unsigned char lexeme; /* Code that identifies the type of this node */
+ int left; /* Index of the left operand of this operator node */
+ int right; /* Index of the right operand of this operator node */
+ int parent; /* Index of the operator of this operand node */
+ int token; /* Index of the Tcl_Tokens of this leaf node */
+} ExprNode;
+
+/*
+ * Set of lexeme codes stored in ExprNode structs to label and categorize
+ * the lexemes found.
+ */
+
+#define LEAF (1<<7)
+#define UNARY (1<<6)
+#define BINARY (1<<5)
+
+#define NODE_TYPE ( LEAF | UNARY | BINARY)
+
+#define PLUS 1
+#define MINUS 2
+#define BAREWORD 3
+#define INCOMPLETE 4
+#define INVALID 5
+
+#define NUMBER ( LEAF | 1)
+#define SCRIPT ( LEAF | 2)
+#define BOOLEAN ( LEAF | BAREWORD)
+#define BRACED ( LEAF | 4)
+#define VARIABLE ( LEAF | 5)
+#define QUOTED ( LEAF | 6)
+#define EMPTY ( LEAF | 7)
+
+#define UNARY_PLUS ( UNARY | PLUS)
+#define UNARY_MINUS ( UNARY | MINUS)
+#define FUNCTION ( UNARY | BAREWORD)
+#define START ( UNARY | 4)
+#define OPEN_PAREN ( UNARY | 5)
+#define NOT ( UNARY | 6)
+#define BIT_NOT ( UNARY | 7)
+
+#define BINARY_PLUS ( BINARY | PLUS)
+#define BINARY_MINUS ( BINARY | MINUS)
+#define COMMA ( BINARY | 3)
+#define MULT ( BINARY | 4)
+#define DIVIDE ( BINARY | 5)
+#define MOD ( BINARY | 6)
+#define LESS ( BINARY | 7)
+#define GREATER ( BINARY | 8)
+#define BIT_AND ( BINARY | 9)
+#define BIT_XOR ( BINARY | 10)
+#define BIT_OR ( BINARY | 11)
+#define QUESTION ( BINARY | 12)
+#define COLON ( BINARY | 13)
+#define LEFT_SHIFT ( BINARY | 14)
+#define RIGHT_SHIFT ( BINARY | 15)
+#define LEQ ( BINARY | 16)
+#define GEQ ( BINARY | 17)
+#define EQUAL ( BINARY | 18)
+#define NEQ ( BINARY | 19)
+#define AND ( BINARY | 20)
+#define OR ( BINARY | 21)
+#define STREQ ( BINARY | 22)
+#define STRNEQ ( BINARY | 23)
+#define EXPON ( BINARY | 24)
+#define IN_LIST ( BINARY | 25)
+#define NOT_IN_LIST ( BINARY | 26)
+#define CLOSE_PAREN ( BINARY | 27)
+#define END ( BINARY | 28)
+
+/*
+ * Declarations for local functions to this file:
+ */
+
+static void GenerateTokens(ExprNode *nodes, Tcl_Parse *scratchPtr,
+ Tcl_Parse *parsePtr);
+static int ParseLexeme(CONST char *start, int numBytes,
+ unsigned char *lexemePtr);
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ParseExpr --
+ *
+ * Given a string, the numBytes bytes starting at start, this function
+ * parses it as a Tcl expression and stores information about the
+ * structure of the expression in the Tcl_Parse struct indicated by the
+ * caller.
+ *
+ * Results:
+ * If the string is successfully parsed as a valid Tcl expression,
+ * TCL_OK is returned, and data about the expression structure is
+ * written to *parsePtr. If the string cannot be parsed as a valid
+ * Tcl expression, TCL_ERROR is returned, and if interp is non-NULL,
+ * an error message is written to interp.
+ *
+ * Side effects:
+ * If there is insufficient space in parsePtr to hold all the information
+ * about the expression, then additional space is malloc-ed. If the
+ * function returns TCL_OK then the caller must eventually invoke
+ * Tcl_FreeParse to release any additional space that was allocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_ParseExpr(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ CONST char *start, /* Start of source string to parse. */
+ int numBytes, /* Number of bytes in string. If < 0, the
+ * string consists of all bytes up to the
+ * first null character. */
+ Tcl_Parse *parsePtr) /* Structure to fill with information about
+ * the parsed expression; any previous
+ * information in the structure is ignored. */
+{
+#define NUM_STATIC_NODES 64
+ ExprNode staticNodes[NUM_STATIC_NODES];
+ ExprNode *lastOrphanPtr, *nodes = staticNodes;
+ int nodesAvailable = NUM_STATIC_NODES;
+ int nodesUsed = 0;
+ Tcl_Parse scratch; /* Parsing scratch space */
+ Tcl_Obj *msg = NULL, *post = NULL;
+ int scanned = 0, code = TCL_OK, insertMark = 0;
+ CONST char *mark = "_@_";
+ CONST int limit = 25;
+ static CONST unsigned char prec[80] = {
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 15, 15, 5, 16, 16, 16, 13, 13, 11, 10, 9, 6, 6, 14, 14,
+ 13, 13, 12, 12, 8, 7, 12, 12, 17, 12, 12, 3, 1, 0, 0, 0,
+ 0, 18, 18, 18, 2, 4, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0,
+ };
+
+ if (numBytes < 0) {
+ numBytes = (start ? strlen(start) : 0);
+ }
+
+ TclParseInit(interp, start, numBytes, &scratch);
+ TclParseInit(interp, start, numBytes, parsePtr);
+
+ /* Initialize the parse tree with the special "START" node */
+
+ nodes->lexeme = START;
+ nodes->left = -1;
+ nodes->right = -1;
+ nodes->parent = -1;
+ nodes->token = -1;
+ lastOrphanPtr = nodes;
+ nodesUsed++;
+
+ while ((code == TCL_OK) && (lastOrphanPtr->lexeme != END)) {
+ ExprNode *nodePtr, *lastNodePtr;
+ Tcl_Token *tokenPtr;
+
+ /*
+ * Each pass through this loop adds one more ExprNode.
+ * Allocate space for one if required.
+ */
+ if (nodesUsed >= nodesAvailable) {
+ int lastOrphanIdx = lastOrphanPtr - nodes;
+ int size = nodesUsed * 2;
+ ExprNode *newPtr;
+
+ if (nodes == staticNodes) {
+ nodes = NULL;
+ }
+ do {
+ newPtr = (ExprNode *) attemptckrealloc( (char *) nodes,
+ (unsigned int) (size * sizeof(ExprNode)) );
+ } while ((newPtr == NULL)
+ && ((size -= (size - nodesUsed) / 2) > nodesUsed));
+ if (newPtr == NULL) {
+ msg = Tcl_NewStringObj(
+ "not enough memory to parse expression", -1);
+ code = TCL_ERROR;
+ continue;
+ }
+ nodesAvailable = size;
+ if (nodes == NULL) {
+ memcpy((VOID *) newPtr, (VOID *) staticNodes,
+ (size_t) (nodesUsed * sizeof(ExprNode)));
+ }
+ nodes = newPtr;
+ lastOrphanPtr = nodes + lastOrphanIdx;
+ }
+ nodePtr = nodes + nodesUsed;
+ lastNodePtr = nodePtr - 1;
+
+ /* Skip white space between lexemes */
+
+ scanned = TclParseAllWhiteSpace(start, numBytes);
+ start += scanned;
+ numBytes -= scanned;
+
+ scanned = ParseLexeme(start, numBytes, &(nodePtr->lexeme));
+
+ /* Use context to categorize the lexemes that are ambiguous */
+
+ if ((NODE_TYPE & nodePtr->lexeme) == 0) {
+ switch (nodePtr->lexeme) {
+ case INVALID:
+ msg = TclObjPrintf(
+ "invalid character \"%.*s\"", scanned, start);
+ code = TCL_ERROR;
+ continue;
+ case INCOMPLETE:
+ msg = TclObjPrintf(
+ "incomplete operator \"%.*s\"", scanned, start);
+ code = TCL_ERROR;
+ continue;
+ case BAREWORD:
+ if (start[scanned+TclParseAllWhiteSpace(
+ start+scanned, numBytes-scanned)] == '(') {
+ nodePtr->lexeme = FUNCTION;
+ } else {
+ Tcl_Obj *objPtr = Tcl_NewStringObj(start, scanned);
+ Tcl_IncrRefCount(objPtr);
+ code = Tcl_ConvertToType(NULL, objPtr, &tclBooleanType);
+ Tcl_DecrRefCount(objPtr);
+ if (code == TCL_OK) {
+ nodePtr->lexeme = BOOLEAN;
+ } else {
+ msg = TclObjPrintf(
+ "invalid bareword \"%.*s%s\"",
+ (scanned < limit) ? scanned : limit - 3, start,
+ (scanned < limit) ? "" : "...");
+ post = TclObjPrintf(
+ "should be \"$%.*s%s\" or \"{%.*s%s}\"",
+ (scanned < limit) ? scanned : limit - 3,
+ start, (scanned < limit) ? "" : "...",
+ (scanned < limit) ? scanned : limit - 3,
+ start, (scanned < limit) ? "" : "...");
+ TclAppendPrintfToObj(post,
+ " or \"%.*s%s(...)\" or ...",
+ (scanned < limit) ? scanned : limit - 3,
+ start, (scanned < limit) ? "" : "...");
+ continue;
+ }
+ }
+ break;
+ case PLUS:
+ case MINUS:
+ if ((NODE_TYPE & lastNodePtr->lexeme) == LEAF) {
+ nodePtr->lexeme |= BINARY;
+ } else {
+ nodePtr->lexeme |= UNARY;
+ }
+ }
+ }
+
+ /* Add node to parse tree based on category */
+
+ switch (NODE_TYPE & nodePtr->lexeme) {
+ case LEAF: {
+ CONST char *end;
+
+ if ((NODE_TYPE & lastNodePtr->lexeme) == LEAF) {
+ CONST char *operand =
+ scratch.tokenPtr[lastNodePtr->token].start;
+
+ msg = TclObjPrintf("missing operator at %s", mark);
+ if (operand[0] == '0') {
+ Tcl_Obj *copy = Tcl_NewStringObj(operand,
+ start + scanned - operand);
+ if (TclCheckBadOctal(NULL, Tcl_GetString(copy))) {
+ post = Tcl_NewStringObj(
+ "looks like invalid octal number", -1);
+ }
+ Tcl_DecrRefCount(copy);
+ }
+ scanned = 0;
+ insertMark = 1;
+ code = TCL_ERROR;
+ continue;
+ }
+
+ if (scratch.numTokens+1 >= scratch.tokensAvailable) {
+ TclExpandTokenArray(&scratch);
+ }
+ nodePtr->token = scratch.numTokens;
+ tokenPtr = scratch.tokenPtr + nodePtr->token;
+ tokenPtr->type = TCL_TOKEN_SUB_EXPR;
+ tokenPtr->start = start;
+ scratch.numTokens++;
+
+ switch (nodePtr->lexeme) {
+ case NUMBER:
+ case BOOLEAN:
+ tokenPtr = scratch.tokenPtr + scratch.numTokens;
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->start = start;
+ tokenPtr->size = scanned;
+ tokenPtr->numComponents = 0;
+ scratch.numTokens++;
+
+ break;
+
+ case QUOTED:
+ code = Tcl_ParseQuotedString(interp, start, numBytes,
+ &scratch, 1, &end);
+ if (code != TCL_OK) {
+ scanned = scratch.term - start;
+ scanned += (scanned < numBytes);
+ continue;
+ }
+ scanned = end - start;
+ break;
+
+ case BRACED:
+ code = Tcl_ParseBraces(interp, start, numBytes,
+ &scratch, 1, &end);
+ if (code != TCL_OK) {
+ continue;
+ }
+ scanned = end - start;
+ break;
+
+ case VARIABLE:
+ code = Tcl_ParseVarName(interp, start, numBytes, &scratch, 1);
+ if (code != TCL_OK) {
+ scanned = scratch.term - start;
+ scanned += (scanned < numBytes);
+ continue;
+ }
+ tokenPtr = scratch.tokenPtr + nodePtr->token + 1;
+ if (tokenPtr->type != TCL_TOKEN_VARIABLE) {
+ msg = Tcl_NewStringObj("invalid character \"$\"", -1);
+ code = TCL_ERROR;
+ continue;
+ }
+ scanned = tokenPtr->size;
+ break;
+
+ case SCRIPT:
+ tokenPtr = scratch.tokenPtr + scratch.numTokens;
+ tokenPtr->type = TCL_TOKEN_COMMAND;
+ tokenPtr->start = start;
+ tokenPtr->numComponents = 0;
+
+ end = start + numBytes;
+ start++;
+ while (1) {
+ Tcl_Parse nested;
+ code = Tcl_ParseCommand(interp,
+ start, (end - start), 1, &nested);
+ if (code != TCL_OK) {
+ parsePtr->term = nested.term;
+ parsePtr->errorType = nested.errorType;
+ parsePtr->incomplete = nested.incomplete;
+ break;
+ }
+ start = (nested.commandStart + nested.commandSize);
+ Tcl_FreeParse(&nested);
+ if ((nested.term < end) && (*nested.term == ']')
+ && !nested.incomplete) {
+ break;
+ }
+
+ if (start == end) {
+ msg = Tcl_NewStringObj("missing close-bracket", -1);
+ parsePtr->term = tokenPtr->start;
+ parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
+ parsePtr->incomplete = 1;
+ code = TCL_ERROR;
+ break;
+ }
+ }
+ end = start;
+ start = tokenPtr->start;
+ if (code != TCL_OK) {
+ scanned = parsePtr->term - start;
+ scanned += (scanned < numBytes);
+ continue;
+ }
+ scanned = end - start;
+ tokenPtr->size = scanned;
+ scratch.numTokens++;
+ break;
+ }
+
+ tokenPtr = scratch.tokenPtr + nodePtr->token;
+ tokenPtr->size = scanned;
+ tokenPtr->numComponents = scratch.numTokens - nodePtr->token - 1;
+
+ nodePtr->left = -1;
+ nodePtr->right = -1;
+ nodePtr->parent = -1;
+ lastOrphanPtr = nodePtr;
+ nodesUsed++;
+ break;
+ }
+
+ case UNARY:
+ if ((NODE_TYPE & lastNodePtr->lexeme) == LEAF) {
+ msg = TclObjPrintf("missing operator at %s", mark);
+ scanned = 0;
+ insertMark = 1;
+ code = TCL_ERROR;
+ continue;
+ }
+ nodePtr->left = -1;
+ nodePtr->right = -1;
+ nodePtr->parent = -1;
+
+ if (scratch.numTokens >= scratch.tokensAvailable) {
+ TclExpandTokenArray(&scratch);
+ }
+ nodePtr->token = scratch.numTokens;
+ tokenPtr = scratch.tokenPtr + nodePtr->token;
+ tokenPtr->type = TCL_TOKEN_OPERATOR;
+ tokenPtr->start = start;
+ tokenPtr->size = scanned;
+ tokenPtr->numComponents = 0;
+ scratch.numTokens++;
+
+ lastOrphanPtr = nodePtr;
+ nodesUsed++;
+ break;
+
+ case BINARY: {
+ ExprNode *otherPtr = NULL;
+ unsigned char precedence = prec[nodePtr->lexeme];
+
+ if ((nodePtr->lexeme == CLOSE_PAREN)
+ && (lastNodePtr->lexeme == OPEN_PAREN)) {
+ if (lastNodePtr[-1].lexeme == FUNCTION) {
+ /* Normally, "()" is a syntax error, but as a special
+ * case accept it as an argument list for a function */
+ scanned = 0;
+ nodePtr->lexeme = EMPTY;
+ nodePtr->left = -1;
+ nodePtr->right = -1;
+ nodePtr->parent = -1;
+ nodePtr->token = -1;
+
+ lastOrphanPtr = nodePtr;
+ nodesUsed++;
+ break;
+
+ }
+ msg = TclObjPrintf("empty subexpression at %s", mark);
+ scanned = 0;
+ insertMark = 1;
+ code = TCL_ERROR;
+ continue;
+ }
+
+
+ if ((NODE_TYPE & lastNodePtr->lexeme) != LEAF) {
+ if (prec[lastNodePtr->lexeme] > precedence) {
+ if (lastNodePtr->lexeme == OPEN_PAREN) {
+ msg = Tcl_NewStringObj("unbalanced open paren", -1);
+ } else if (lastNodePtr->lexeme == COMMA) {
+ msg = TclObjPrintf(
+ "missing function argument at %s", mark);
+ scanned = 0;
+ insertMark = 1;
+ } else if (lastNodePtr->lexeme == START) {
+ msg = Tcl_NewStringObj("empty expression", -1);
+ }
+ } else {
+ if (nodePtr->lexeme == CLOSE_PAREN) {
+ msg = Tcl_NewStringObj("unbalanced close paren", -1);
+ } else if ((nodePtr->lexeme == COMMA)
+ && (lastNodePtr->lexeme == OPEN_PAREN)
+ && (lastNodePtr[-1].lexeme == FUNCTION)) {
+ msg = TclObjPrintf(
+ "missing function argument at %s", mark);
+ scanned = 0;
+ insertMark = 1;
+ }
+ }
+ if (msg == NULL) {
+ msg = TclObjPrintf("missing operand at %s", mark);
+ scanned = 0;
+ insertMark = 1;
+ }
+ code = TCL_ERROR;
+ continue;
+ }
+
+ while (1) {
+
+ if (lastOrphanPtr->parent >= 0) {
+ otherPtr = nodes + lastOrphanPtr->parent;
+ } else if (lastOrphanPtr->left >= 0) {
+ Tcl_Panic("Tcl_ParseExpr: left closure programming error");
+ } else {
+ lastOrphanPtr->parent = lastOrphanPtr - nodes;
+ otherPtr = lastOrphanPtr;
+ }
+ otherPtr--;
+
+ if (prec[otherPtr->lexeme] < precedence) {
+ break;
+ }
+
+ if (prec[otherPtr->lexeme] == precedence) {
+ /* Special association rules for the ternary operators. */
+ if ((otherPtr->lexeme == QUESTION)
+ && (lastOrphanPtr->lexeme != COLON)) {
+ break;
+ }
+ if ((otherPtr->lexeme == COLON)
+ && (nodePtr->lexeme == QUESTION)) {
+ break;
+ }
+ /* Right association rules for exponentiation. */
+ if (nodePtr->lexeme == EXPON) {
+ break;
+ }
+ }
+
+ /* Some checks before linking */
+ if ((otherPtr->lexeme == OPEN_PAREN)
+ && (nodePtr->lexeme != CLOSE_PAREN)) {
+ lastOrphanPtr = otherPtr;
+ msg = Tcl_NewStringObj("unbalanced open paren", -1);
+ code = TCL_ERROR;
+ break;
+ }
+ if ((otherPtr->lexeme == QUESTION)
+ && (lastOrphanPtr->lexeme != COLON)) {
+ msg = TclObjPrintf(
+ "missing operator \":\" at %s", mark);
+ scanned = 0;
+ insertMark = 1;
+ code = TCL_ERROR;
+ break;
+ }
+ if ((lastOrphanPtr->lexeme == COLON)
+ && (otherPtr->lexeme != QUESTION)) {
+ msg = Tcl_NewStringObj(
+ "unexpected operator \":\" without preceding \"?\"",
+ -1);
+ code = TCL_ERROR;
+ break;
+ }
+
+ /* Link orphan as right operand of otherPtr */
+ otherPtr->right = lastOrphanPtr - nodes;
+ lastOrphanPtr->parent = otherPtr - nodes;
+ lastOrphanPtr = otherPtr;
+
+ if (otherPtr->lexeme == OPEN_PAREN) {
+ /* CLOSE_PAREN can only close one OPEN_PAREN */
+ tokenPtr = scratch.tokenPtr + otherPtr->token;
+ tokenPtr->size = start + scanned - tokenPtr->start;
+ break;
+ }
+ if (otherPtr->lexeme == START) {
+ /* Don't backtrack beyond the start */
+ break;
+ }
+ }
+ if (code != TCL_OK) {
+ continue;
+ }
+
+ if (nodePtr->lexeme == CLOSE_PAREN) {
+ if (otherPtr->lexeme == START) {
+ msg = Tcl_NewStringObj("unbalanced close paren", -1);
+ code = TCL_ERROR;
+ continue;
+ }
+ /* Create no node for a CLOSE_PAREN lexeme */
+ break;
+ }
+
+ if ((nodePtr->lexeme == COMMA) && ((otherPtr->lexeme != OPEN_PAREN)
+ || (otherPtr[-1].lexeme != FUNCTION))) {
+ msg = Tcl_NewStringObj(
+ "unexpected \",\" outside function argument list", -1);
+ code = TCL_ERROR;
+ continue;
+ }
+
+ if (lastOrphanPtr->lexeme == COLON) {
+ msg = Tcl_NewStringObj(
+ "unexpected operator \":\" without preceding \"?\"",
+ -1);
+ code = TCL_ERROR;
+ continue;
+ }
+
+ /* Link orphan as left operand of new node */
+ nodePtr->right = -1;
+
+ if (scratch.numTokens >= scratch.tokensAvailable) {
+ TclExpandTokenArray(&scratch);
+ }
+ nodePtr->token = scratch.numTokens;
+ tokenPtr = scratch.tokenPtr + nodePtr->token;
+ tokenPtr->type = TCL_TOKEN_OPERATOR;
+ tokenPtr->start = start;
+ tokenPtr->size = scanned;
+ tokenPtr->numComponents = 0;
+ scratch.numTokens++;
+
+ nodePtr->left = lastOrphanPtr - nodes;
+ nodePtr->parent = lastOrphanPtr->parent;
+ lastOrphanPtr->parent = nodePtr - nodes;
+ lastOrphanPtr = nodePtr;
+ nodesUsed++;
+ break;
+ }
+ }
+
+ start += scanned;
+ numBytes -= scanned;
+ }
+
+ if (code == TCL_OK) {
+ /* Shift tokens from scratch space to caller space */
+ GenerateTokens(nodes, &scratch, parsePtr);
+ } else {
+ if (parsePtr->errorType == TCL_PARSE_SUCCESS) {
+ parsePtr->errorType = TCL_PARSE_SYNTAX;
+ parsePtr->term = start;
+ }
+ if (interp == NULL) {
+ if (msg) {
+ Tcl_DecrRefCount(msg);
+ }
+ } else {
+ if (msg == NULL) {
+ msg = Tcl_GetObjResult(interp);
+ }
+ TclAppendPrintfToObj(msg, "\nin expression \"%s%.*s%.*s%s%s%.*s%s\"",
+ ((start - limit) < scratch.string) ? "" : "...",
+ ((start - limit) < scratch.string)
+ ? (start - scratch.string) : limit - 3,
+ ((start - limit) < scratch.string)
+ ? scratch.string : start - limit + 3,
+ (scanned < limit) ? scanned : limit - 3, start,
+ (scanned < limit) ? "" : "...",
+ insertMark ? mark : "",
+ (start + scanned + limit > scratch.end)
+ ? scratch.end - (start + scanned) : limit-3,
+ start + scanned,
+ (start + scanned + limit > scratch.end) ? "" : "..."
+ );
+ if (post != NULL) {
+ Tcl_AppendToObj(msg, ";\n", -1);
+ Tcl_AppendObjToObj(msg, post);
+ Tcl_DecrRefCount(post);
+ }
+ Tcl_SetObjResult(interp, msg);
+ numBytes = scratch.end - scratch.string;
+ TclAppendObjToErrorInfo(interp, TclObjPrintf(
+ "\n (parsing expression \"%.*s%s\")",
+ (numBytes < limit) ? numBytes : limit - 3,
+ scratch.string, (numBytes < limit) ? "" : "..."));
+ }
+ }
+
+ if (nodes != staticNodes) {
+ ckfree((char *)nodes);
+ }
+ Tcl_FreeParse(&scratch);
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GenerateTokens --
+ *
+ * Routine that generates Tcl_Tokens that represent a Tcl expression
+ * and writes them to *parsePtr. The parse tree of the expression
+ * is in the array of ExprNodes, nodes. Some of the Tcl_Tokens are
+ * copied from scratch space at *scratchPtr, where the parsing pass
+ * that constructed the parse tree left them.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+GenerateTokens(
+ ExprNode *nodes,
+ Tcl_Parse *scratchPtr,
+ Tcl_Parse *parsePtr)
+{
+ ExprNode *nodePtr = nodes + nodes->right;
+ Tcl_Token *sourcePtr, *destPtr, *tokenPtr = scratchPtr->tokenPtr;
+ int toCopy;
+ CONST char *end = tokenPtr->start + tokenPtr->size;
+
+ while (nodePtr->lexeme != START) {
+ switch (NODE_TYPE & nodePtr->lexeme) {
+ case BINARY:
+ if (nodePtr->left >= 0) {
+ if ((nodePtr->lexeme != COMMA) && (nodePtr->lexeme != COLON)) {
+ sourcePtr = scratchPtr->tokenPtr + nodePtr->token;
+ if (parsePtr->numTokens + 1 >= parsePtr->tokensAvailable) {
+ TclExpandTokenArray(parsePtr);
+ }
+ destPtr = parsePtr->tokenPtr + parsePtr->numTokens;
+ nodePtr->token = parsePtr->numTokens;
+ destPtr->type = TCL_TOKEN_SUB_EXPR;
+ destPtr->start = tokenPtr->start;
+ destPtr++;
+ *destPtr = *sourcePtr;
+ parsePtr->numTokens += 2;
+ }
+ nodePtr = nodes + nodePtr->left;
+ nodes[nodePtr->parent].left = -1;
+ } else if (nodePtr->right >= 0) {
+ tokenPtr += tokenPtr->numComponents + 1;
+ nodePtr = nodes + nodePtr->right;
+ nodes[nodePtr->parent].right = -1;
+ } else {
+ if ((nodePtr->lexeme != COMMA) && (nodePtr->lexeme != COLON)) {
+ destPtr = parsePtr->tokenPtr + nodePtr->token;
+ destPtr->size = end - destPtr->start;
+ destPtr->numComponents =
+ parsePtr->numTokens - nodePtr->token - 1;
+ }
+ nodePtr = nodes + nodePtr->parent;
+ }
+ break;
+
+ case UNARY:
+ if (nodePtr->right >= 0) {
+ sourcePtr = scratchPtr->tokenPtr + nodePtr->token;
+ if (nodePtr->lexeme != OPEN_PAREN) {
+ if (parsePtr->numTokens + 1 >= parsePtr->tokensAvailable) {
+ TclExpandTokenArray(parsePtr);
+ }
+ destPtr = parsePtr->tokenPtr + parsePtr->numTokens;
+ nodePtr->token = parsePtr->numTokens;
+ destPtr->type = TCL_TOKEN_SUB_EXPR;
+ destPtr->start = tokenPtr->start;
+ destPtr++;
+ *destPtr = *sourcePtr;
+ parsePtr->numTokens += 2;
+ }
+ if (tokenPtr == sourcePtr) {
+ tokenPtr += tokenPtr->numComponents + 1;
+ }
+ nodePtr = nodes + nodePtr->right;
+ nodes[nodePtr->parent].right = -1;
+ } else {
+ if (nodePtr->lexeme != OPEN_PAREN) {
+ destPtr = parsePtr->tokenPtr + nodePtr->token;
+ destPtr->size = end - destPtr->start;
+ destPtr->numComponents =
+ parsePtr->numTokens - nodePtr->token - 1;
+ } else {
+ sourcePtr = scratchPtr->tokenPtr + nodePtr->token;
+ end = sourcePtr->start + sourcePtr->size;
+ }
+ nodePtr = nodes + nodePtr->parent;
+ }
+ break;
+
+ case LEAF:
+ switch (nodePtr->lexeme) {
+ case EMPTY:
+ break;
+
+ case BRACED:
+ case QUOTED:
+ sourcePtr = scratchPtr->tokenPtr + nodePtr->token;
+ end = sourcePtr->start + sourcePtr->size;
+ if (sourcePtr->numComponents > 1) {
+ toCopy = sourcePtr->numComponents;
+ if (tokenPtr == sourcePtr) {
+ tokenPtr += toCopy + 1;
+ }
+ sourcePtr->numComponents++;
+ while (parsePtr->numTokens + toCopy + 1
+ >= parsePtr->tokensAvailable) {
+ TclExpandTokenArray(parsePtr);
+ }
+ destPtr = parsePtr->tokenPtr + parsePtr->numTokens;
+ *destPtr++ = *sourcePtr;
+ *destPtr = *sourcePtr++;
+ destPtr->type = TCL_TOKEN_WORD;
+ destPtr->numComponents = toCopy;
+ destPtr++;
+ memcpy((VOID *) destPtr, (VOID *) sourcePtr,
+ (size_t) (toCopy * sizeof(Tcl_Token)));
+ parsePtr->numTokens += toCopy + 2;
+ break;
+ }
+
+ default:
+ sourcePtr = scratchPtr->tokenPtr + nodePtr->token;
+ end = sourcePtr->start + sourcePtr->size;
+ toCopy = sourcePtr->numComponents + 1;
+ if (tokenPtr == sourcePtr) {
+ tokenPtr += toCopy;
+ }
+ while (parsePtr->numTokens + toCopy - 1
+ >= parsePtr->tokensAvailable) {
+ TclExpandTokenArray(parsePtr);
+ }
+ destPtr = parsePtr->tokenPtr + parsePtr->numTokens;
+ memcpy((VOID *) destPtr, (VOID *) sourcePtr,
+ (size_t) (toCopy * sizeof(Tcl_Token)));
+ parsePtr->numTokens += toCopy;
+ break;
+
+ }
+ nodePtr = nodes + nodePtr->parent;
+ break;
+
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseLexeme --
+ *
+ * Parse a single lexeme from the start of a string, scanning no
+ * more than numBytes bytes.
+ *
+ * Results:
+ * Returns the number of bytes scanned to produce the lexeme.
+ *
+ * Side effects:
+ * Code identifying lexeme parsed is writen to *lexemePtr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ParseLexeme(
+ CONST char *start, /* Start of lexeme to parse. */
+ int numBytes, /* Number of bytes in string. */
+ unsigned char *lexemePtr) /* Write code of parsed lexeme to this
+ * storage. */
+{
+ CONST char *end;
+ int scanned;
+ Tcl_UniChar ch;
+
+ if (numBytes == 0) {
+ *lexemePtr = END;
+ return 0;
+ }
+ switch (*start) {
+ case '[':
+ *lexemePtr = SCRIPT;
+ return 1;
+
+ case '{':
+ *lexemePtr = BRACED;
+ return 1;
+
+ case '(':
+ *lexemePtr = OPEN_PAREN;
+ return 1;
+
+ case ')':
+ *lexemePtr = CLOSE_PAREN;
+ return 1;
+
+ case '$':
+ *lexemePtr = VARIABLE;
+ return 1;
+
+ case '\"':
+ *lexemePtr = QUOTED;
+ return 1;
+
+ case ',':
+ *lexemePtr = COMMA;
+ return 1;
+
+ case '/':
+ *lexemePtr = DIVIDE;
+ return 1;
+
+ case '%':
+ *lexemePtr = MOD;
+ return 1;
+
+ case '+':
+ *lexemePtr = PLUS;
+ return 1;
+
+ case '-':
+ *lexemePtr = MINUS;
+ return 1;
+
+ case '?':
+ *lexemePtr = QUESTION;
+ return 1;
+
+ case ':':
+ *lexemePtr = COLON;
+ return 1;
+
+ case '^':
+ *lexemePtr = BIT_XOR;
+ return 1;
+
+ case '~':
+ *lexemePtr = BIT_NOT;
+ return 1;
+
+ case '*':
+ if ((numBytes > 1) && (start[1] == '*')) {
+ *lexemePtr = EXPON;
+ return 2;
+ }
+ *lexemePtr = MULT;
+ return 1;
+
+ case '=':
+ if ((numBytes > 1) && (start[1] == '=')) {
+ *lexemePtr = EQUAL;
+ return 2;
+ }
+ *lexemePtr = INCOMPLETE;
+ return 1;
+
+ case '!':
+ if ((numBytes > 1) && (start[1] == '=')) {
+ *lexemePtr = NEQ;
+ return 2;
+ }
+ *lexemePtr = NOT;
+ return 1;
+
+ case '&':
+ if ((numBytes > 1) && (start[1] == '&')) {
+ *lexemePtr = AND;
+ return 2;
+ }
+ *lexemePtr = BIT_AND;
+ return 1;
+
+ case '|':
+ if ((numBytes > 1) && (start[1] == '|')) {
+ *lexemePtr = OR;
+ return 2;
+ }
+ *lexemePtr = BIT_OR;
+ return 1;
+
+ case '<':
+ if (numBytes > 1) {
+ switch (start[1]) {
+ case '<':
+ *lexemePtr = LEFT_SHIFT;
+ return 2;
+ case '=':
+ *lexemePtr = LEQ;
+ return 2;
+ }
+ }
+ *lexemePtr = LESS;
+ return 1;
+
+ case '>':
+ if (numBytes > 1) {
+ switch (start[1]) {
+ case '>':
+ *lexemePtr = RIGHT_SHIFT;
+ return 2;
+ case '=':
+ *lexemePtr = GEQ;
+ return 2;
+ }
+ }
+ *lexemePtr = GREATER;
+ return 1;
+
+ case 'i':
+ if ((numBytes > 1) && (start[1] == 'n')
+ && ((numBytes == 2) || !isalpha(UCHAR(start[2])))) {
+ /*
+ * Must make this check so we can tell the difference between
+ * the "in" operator and the "int" function name and the
+ * "infinity" numeric value.
+ */
+ *lexemePtr = IN_LIST;
+ return 2;
+ }
+ break;
+
+ case 'e':
+ if ((numBytes > 1) && (start[1] == 'q')
+ && ((numBytes == 2) || !isalpha(UCHAR(start[2])))) {
+ *lexemePtr = STREQ;
+ return 2;
+ }
+ break;
+
+ case 'n':
+ if ((numBytes > 1) && ((numBytes == 2) || !isalpha(UCHAR(start[2])))) {
+ switch (start[1]) {
+ case 'e':
+ *lexemePtr = STRNEQ;
+ return 2;
+ case 'i':
+ *lexemePtr = NOT_IN_LIST;
+ return 2;
+ }
+ }
+ }
+
+ if (TclParseNumber(NULL, NULL, NULL, start, numBytes, &end,
+ TCL_PARSE_NO_WHITESPACE) == TCL_OK) {
+ *lexemePtr = NUMBER;
+ return (end-start);
+ }
+
+ if (Tcl_UtfCharComplete(start, numBytes)) {
+ scanned = Tcl_UtfToUniChar(start, &ch);
+ } else {
+ char utfBytes[TCL_UTF_MAX];
+ memcpy(utfBytes, start, (size_t) numBytes);
+ utfBytes[numBytes] = '\0';
+ scanned = Tcl_UtfToUniChar(utfBytes, &ch);
+ }
+ if (!isalpha(UCHAR(ch))) {
+ *lexemePtr = INVALID;
+ return scanned;
+ }
+ end = start;
+ while (isalnum(UCHAR(ch)) || (UCHAR(ch) == '_')) {
+ end += scanned;
+ numBytes -= scanned;
+ if (Tcl_UtfCharComplete(end, numBytes)) {
+ scanned = Tcl_UtfToUniChar(end, &ch);
+ } else {
+ char utfBytes[TCL_UTF_MAX];
+ memcpy(utfBytes, end, (size_t) numBytes);
+ utfBytes[numBytes] = '\0';
+ scanned = Tcl_UtfToUniChar(utfBytes, &ch);
+ }
+ }
+ *lexemePtr = BAREWORD;
+ return (end-start);
+}
+
+/*
* Boolean variable that controls whether expression compilation tracing is
* enabled.
*/