/* * tclCompExpr.c -- * * This file contains the code to compile Tcl expressions. * * 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.54 2007/06/20 18:46:11 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" #undef USE_EXPR_TOKENS #undef PARSE_DIRECT_EXPR_TOKENS #ifdef PARSE_DIRECT_EXPR_TOKENS /* * 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; #endif /* * Integer codes indicating the form of an operand of an operator. */ enum OperandTypes { OT_NONE = -4, OT_LITERAL = -3, OT_TOKENS = -2, OT_EMPTY = -1 }; /* * The OpNode structure represents one operator node in the parse tree * produced as an interim structure by the expression parser. */ typedef struct OpNode { unsigned char lexeme; /* Code that identifies the operator. */ int left; /* Index of the left operand. Non-negative * integer is an index into the parse tree, * pointing to another operator. Value * OT_LITERAL indicates operand is the next * entry in the literal list. Value OT_TOKENS * indicates the operand is the next word in * the Tcl_Parse struct. Value OT_NONE * indicates we haven't yet parsed the operand * for this operator. */ int right; /* Index of the right operand. Same * interpretation as left, with addition of * OT_EMPTY meaning zero arguments. */ int parent; /* Index of the operator of this operand * node. */ } OpNode; /* * 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 int ParseLexeme(const char *start, int numBytes, unsigned char *lexemePtr, Tcl_Obj **literalPtr); #if (!defined(PARSE_DIRECT_EXPR_TOKENS) || !defined(USE_EXPR_TOKENS)) static int ParseExpr(Tcl_Interp *interp, const char *start, int numBytes, OpNode **opTreePtr, Tcl_Obj *litList, Tcl_Obj *funcList, Tcl_Parse *parsePtr); #endif #ifdef PARSE_DIRECT_EXPR_TOKENS static void GenerateTokens(ExprNode *nodes, Tcl_Parse *scratchPtr, Tcl_Parse *parsePtr); #else static void ConvertTreeToTokens(Tcl_Interp *interp, const char *start, int numBytes, OpNode *nodes, Tcl_Obj *litList, Tcl_Token *tokenPtr, Tcl_Parse *parsePtr); static int GenerateTokensForLiteral(const char *script, int numBytes, Tcl_Obj *litList, int nextLiteral, Tcl_Parse *parsePtr); static int CopyTokens(Tcl_Token *sourcePtr, Tcl_Parse *parsePtr); #endif #if (!defined(PARSE_DIRECT_EXPR_TOKENS) || !defined(USE_EXPR_TOKENS)) /* *---------------------------------------------------------------------- * * 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. * *---------------------------------------------------------------------- */ static int ParseExpr( Tcl_Interp *interp, /* Used for error reporting. */ const char *start, /* Start of source string to parse. */ int numBytes, /* Number of bytes in string. If < 0, the * string consists of all bytes up to the * first null character. */ OpNode **opTreePtr, /* Points to space where a pointer to the * allocated OpNode tree should go. */ Tcl_Obj *litList, /* List to append literals to. */ Tcl_Obj *funcList, /* List to append function names to. */ Tcl_Parse *parsePtr) /* Structure to fill with tokens representing * those operands that require run time * substitutions. */ { OpNode *nodes = NULL; int nodesAvailable = 64, nodesUsed = 0; int code = TCL_OK; int numLiterals = 0, numFuncs = 0; int scanned = 0, insertMark = 0; int lastOpen = 0, lastWas = 0; unsigned char lexeme = START; Tcl_Obj *msg = NULL, *post = NULL; const int limit = 25; const char *mark = "_@_"; static const unsigned char prec[] = { 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, parsePtr); nodes = (OpNode *) attemptckalloc(nodesAvailable * sizeof(OpNode)); if (nodes == NULL) { TclNewLiteralStringObj(msg, "not enough memory to parse expression"); code = TCL_ERROR; } else { /* * Initialize the parse tree with the special "START" node. */ nodes->lexeme = lexeme; nodes->left = OT_NONE; nodes->right = OT_NONE; nodes->parent = -1; nodesUsed++; } while ((code == TCL_OK) && (lexeme != END)) { OpNode *nodePtr; Tcl_Token *tokenPtr = NULL; Tcl_Obj *literal = NULL; const char *lastStart = start - scanned; /* * Each pass through this loop adds one more ExprNode. Allocate space * for one if required. */ if (nodesUsed >= nodesAvailable) { int size = nodesUsed * 2; OpNode *newPtr; do { newPtr = (OpNode *) attemptckrealloc((char *) nodes, (unsigned int) size * sizeof(OpNode)); } while ((newPtr == NULL) && ((size -= (size - nodesUsed) / 2) > nodesUsed)); if (newPtr == NULL) { TclNewLiteralStringObj(msg, "not enough memory to parse expression"); code = TCL_ERROR; continue; } nodesAvailable = size; nodes = newPtr; } nodePtr = nodes + nodesUsed; /* * Skip white space between lexemes. */ scanned = TclParseAllWhiteSpace(start, numBytes); start += scanned; numBytes -= scanned; scanned = ParseLexeme(start, numBytes, &lexeme, &literal); /* * Use context to categorize the lexemes that are ambiguous. */ if ((NODE_TYPE & lexeme) == 0) { switch (lexeme) { case INVALID: msg = Tcl_ObjPrintf( "invalid character \"%.*s\"", scanned, start); code = TCL_ERROR; continue; case INCOMPLETE: msg = Tcl_ObjPrintf( "incomplete operator \"%.*s\"", scanned, start); code = TCL_ERROR; continue; case BAREWORD: if (start[scanned+TclParseAllWhiteSpace( start+scanned, numBytes-scanned)] == '(') { lexeme = FUNCTION; Tcl_ListObjAppendElement(NULL, funcList, literal); numFuncs++; } else { int b; if (Tcl_GetBooleanFromObj(NULL, literal, &b) == TCL_OK) { lexeme = BOOLEAN; } else { Tcl_DecrRefCount(literal); msg = Tcl_ObjPrintf( "invalid bareword \"%.*s%s\"", (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "..."); post = Tcl_ObjPrintf( "should be \"$%.*s%s\" or \"{%.*s%s}\"", (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "...", (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "..."); Tcl_AppendPrintfToObj(post, " or \"%.*s%s(...)\" or ...", (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "..."); code = TCL_ERROR; continue; } } break; case PLUS: case MINUS: if (lastWas < 0) { lexeme |= BINARY; } else { lexeme |= UNARY; } } } /* * Add node to parse tree based on category. */ switch (NODE_TYPE & lexeme) { case LEAF: { const char *end; int wordIndex; /* * Store away any literals on the list now, so they'll * be available for our caller to free if we error out * of this routine. [Bug 1705778, leak K23] */ switch (lexeme) { case NUMBER: case BOOLEAN: Tcl_ListObjAppendElement(NULL, litList, literal); numLiterals++; break; default: break; } if (lastWas < 0) { msg = Tcl_ObjPrintf("missing operator at %s", mark); if (lastStart[0] == '0') { Tcl_Obj *copy = Tcl_NewStringObj(lastStart, start + scanned - lastStart); if (TclCheckBadOctal(NULL, Tcl_GetString(copy))) { TclNewLiteralStringObj(post, "looks like invalid octal number"); } Tcl_DecrRefCount(copy); } scanned = 0; insertMark = 1; code = TCL_ERROR; continue; } switch (lexeme) { case NUMBER: case BOOLEAN: lastWas = OT_LITERAL; start += scanned; numBytes -= scanned; continue; default: break; } /* * Make room for at least 2 more tokens. */ if (parsePtr->numTokens+1 >= parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } wordIndex = parsePtr->numTokens; tokenPtr = parsePtr->tokenPtr + wordIndex; tokenPtr->type = TCL_TOKEN_WORD; tokenPtr->start = start; parsePtr->numTokens++; switch (lexeme) { case QUOTED: code = Tcl_ParseQuotedString(interp, start, numBytes, parsePtr, 1, &end); if (code != TCL_OK) { scanned = parsePtr->term - start; scanned += (scanned < numBytes); continue; } scanned = end - start; break; case BRACED: code = Tcl_ParseBraces(interp, start, numBytes, parsePtr, 1, &end); if (code != TCL_OK) { continue; } scanned = end - start; break; case VARIABLE: code = Tcl_ParseVarName(interp, start, numBytes, parsePtr, 1); if (code != TCL_OK) { scanned = parsePtr->term - start; scanned += (scanned < numBytes); continue; } tokenPtr = parsePtr->tokenPtr + wordIndex + 1; if (tokenPtr->type != TCL_TOKEN_VARIABLE) { TclNewLiteralStringObj(msg, "invalid character \"$\""); code = TCL_ERROR; continue; } scanned = tokenPtr->size; break; case SCRIPT: tokenPtr = parsePtr->tokenPtr + parsePtr->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) { TclNewLiteralStringObj(msg, "missing close-bracket"); 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; parsePtr->numTokens++; break; } tokenPtr = parsePtr->tokenPtr + wordIndex; tokenPtr->size = scanned; tokenPtr->numComponents = parsePtr->numTokens - wordIndex - 1; if ((lexeme == QUOTED) || (lexeme == BRACED)) { literal = Tcl_NewObj(); /* TODO: allow all compile-time known words */ if (tokenPtr->numComponents == 1 && tokenPtr[1].type == TCL_TOKEN_TEXT && TclWordKnownAtCompileTime(tokenPtr, literal)) { Tcl_ListObjAppendElement(NULL, litList, literal); numLiterals++; lastWas = OT_LITERAL; parsePtr->numTokens = wordIndex; break; } Tcl_DecrRefCount(literal); } lastWas = OT_TOKENS; break; } case UNARY: if (lastWas < 0) { msg = Tcl_ObjPrintf("missing operator at %s", mark); scanned = 0; insertMark = 1; code = TCL_ERROR; continue; } lastWas = nodesUsed; nodePtr->lexeme = lexeme; nodePtr->left = OT_NONE; nodePtr->right = OT_NONE; nodePtr->parent = nodePtr - nodes - 1; nodesUsed++; break; case BINARY: { OpNode *otherPtr = NULL; unsigned char precedence = prec[lexeme]; if (lastWas >= 0) { if ((lexeme == CLOSE_PAREN) && (nodePtr[-1].lexeme == OPEN_PAREN)) { if (nodePtr[-2].lexeme == FUNCTION) { /* * Normally, "()" is a syntax error, but as a special * case accept it as an argument list for a function. */ scanned = 0; lastWas = OT_EMPTY; nodePtr[-1].left--; break; } msg = Tcl_ObjPrintf("empty subexpression at %s", mark); scanned = 0; insertMark = 1; code = TCL_ERROR; continue; } if (prec[nodePtr[-1].lexeme] > precedence) { if (nodePtr[-1].lexeme == OPEN_PAREN) { TclNewLiteralStringObj(msg, "unbalanced open paren"); } else if (nodePtr[-1].lexeme == COMMA) { msg = Tcl_ObjPrintf( "missing function argument at %s", mark); scanned = 0; insertMark = 1; } else if (nodePtr[-1].lexeme == START) { TclNewLiteralStringObj(msg, "empty expression"); } } else { if (lexeme == CLOSE_PAREN) { TclNewLiteralStringObj(msg, "unbalanced close paren"); } else if ((lexeme == COMMA) && (nodePtr[-1].lexeme == OPEN_PAREN) && (nodePtr[-2].lexeme == FUNCTION)) { msg = Tcl_ObjPrintf( "missing function argument at %s", mark); scanned = 0; insertMark = 1; } } if (msg == NULL) { msg = Tcl_ObjPrintf("missing operand at %s", mark); scanned = 0; insertMark = 1; } code = TCL_ERROR; continue; } if (lastWas == OT_NONE) { otherPtr = nodes + lastOpen - 1; lastWas = lastOpen; } else { otherPtr = nodePtr - 1; } while (1) { /* * lastWas is "index" of item to be linked. otherPtr points to * competing operator. */ if (prec[otherPtr->lexeme] < precedence) { break; } if (prec[otherPtr->lexeme] == precedence) { /* * Right association rules for exponentiation. */ if (lexeme == EXPON) { break; } /* * Special association rules for the ternary operators. * The "?" and ":" operators have equal precedence, but * must be linked up in sensible pairs. */ if ((otherPtr->lexeme == QUESTION) && ((lastWas < 0) || (nodes[lastWas].lexeme != COLON))) { break; } if ((otherPtr->lexeme == COLON) && (lexeme == QUESTION)) { break; } } /* * We should link the lastWas item to the otherPtr as its * right operand. First make some syntax checks. */ if ((otherPtr->lexeme == OPEN_PAREN) && (lexeme != CLOSE_PAREN)) { TclNewLiteralStringObj(msg, "unbalanced open paren"); code = TCL_ERROR; break; } if ((otherPtr->lexeme == QUESTION) && ((lastWas < 0) || (nodes[lastWas].lexeme != COLON))) { msg = Tcl_ObjPrintf( "missing operator \":\" at %s", mark); scanned = 0; insertMark = 1; code = TCL_ERROR; break; } if ((lastWas >= 0) && (nodes[lastWas].lexeme == COLON) && (otherPtr->lexeme != QUESTION)) { TclNewLiteralStringObj(msg, "unexpected operator \":\" without preceding \"?\""); code = TCL_ERROR; break; } /* * Link orphan as right operand of otherPtr. */ otherPtr->right = lastWas; if (lastWas >= 0) { nodes[lastWas].parent = otherPtr - nodes; } lastWas = otherPtr - nodes; if (otherPtr->lexeme == OPEN_PAREN) { /* * CLOSE_PAREN can only close one OPEN_PAREN. */ break; } if (otherPtr->lexeme == START) { /* * Don't backtrack beyond the start. */ break; } otherPtr = nodes + otherPtr->parent; } if (code != TCL_OK) { continue; } if (lexeme == CLOSE_PAREN) { if (otherPtr->lexeme == START) { TclNewLiteralStringObj(msg, "unbalanced close paren"); code = TCL_ERROR; continue; } lastWas = OT_NONE; lastOpen = otherPtr - nodes; otherPtr->left++; /* * Create no node for a CLOSE_PAREN lexeme. */ break; } if (lexeme == COMMA) { if ((otherPtr->lexeme != OPEN_PAREN) || (otherPtr[-1].lexeme != FUNCTION)) { TclNewLiteralStringObj(msg, "unexpected \",\" outside function argument list"); code = TCL_ERROR; continue; } otherPtr->left++; } if ((lastWas >= 0) && (nodes[lastWas].lexeme == COLON)) { TclNewLiteralStringObj(msg, "unexpected operator \":\" without preceding \"?\""); code = TCL_ERROR; continue; } /* * Link orphan as left operand of new node. */ nodePtr->lexeme = lexeme; nodePtr->right = -1; nodePtr->left = lastWas; if (lastWas < 0) { nodePtr->parent = nodePtr - nodes - 1; } else { nodePtr->parent = nodes[lastWas].parent; nodes[lastWas].parent = nodePtr - nodes; } lastWas = nodesUsed; nodesUsed++; break; } } start += scanned; numBytes -= scanned; } if (code != TCL_OK && nodes != NULL) { ckfree((char*) nodes); } if (code == TCL_OK) { *opTreePtr = nodes; } else if (interp == NULL) { if (msg) { Tcl_DecrRefCount(msg); } } else { if (msg == NULL) { msg = Tcl_GetObjResult(interp); } Tcl_AppendPrintfToObj(msg, "\nin expression \"%s%.*s%.*s%s%s%.*s%s\"", ((start - limit) < parsePtr->string) ? "" : "...", ((start - limit) < parsePtr->string) ? (start - parsePtr->string) : limit - 3, ((start - limit) < parsePtr->string) ? parsePtr->string : start - limit + 3, (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "...", insertMark ? mark : "", (start + scanned + limit > parsePtr->end) ? parsePtr->end - (start + scanned) : limit-3, start + scanned, (start + scanned + limit > parsePtr->end) ? "" : "..."); if (post != NULL) { Tcl_AppendToObj(msg, ";\n", -1); Tcl_AppendObjToObj(msg, post); Tcl_DecrRefCount(post); } Tcl_SetObjResult(interp, msg); numBytes = parsePtr->end - parsePtr->string; Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (parsing expression \"%.*s%s\")", (numBytes < limit) ? numBytes : limit - 3, parsePtr->string, (numBytes < limit) ? "" : "...")); } return code; } #endif #ifndef PARSE_DIRECT_EXPR_TOKENS /* *---------------------------------------------------------------------- * * GenerateTokensForLiteral -- * * Results: * Number of bytes scanned. * * Side effects: * The Tcl_Parse *parsePtr is filled with Tcl_Tokens representing the * literal. * *---------------------------------------------------------------------- */ static int GenerateTokensForLiteral( const char *script, int numBytes, Tcl_Obj *litList, int nextLiteral, Tcl_Parse *parsePtr) { int scanned, closer = 0; const char *start = script; Tcl_Token *destPtr; unsigned char lexeme; /* * Have to reparse to get pointers into source string. */ scanned = TclParseAllWhiteSpace(start, numBytes); start +=scanned; scanned = ParseLexeme(start, numBytes-scanned, &lexeme, NULL); if ((lexeme != NUMBER) && (lexeme != BAREWORD)) { Tcl_Obj *literal; const char *bytes; Tcl_ListObjIndex(NULL, litList, nextLiteral, &literal); bytes = Tcl_GetStringFromObj(literal, &scanned); start++; if (memcmp(bytes, start, (size_t) scanned) == 0) { closer = 1; } else { /* TODO */ Tcl_Panic("figure this out"); } } if (parsePtr->numTokens + 1 >= parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } destPtr = parsePtr->tokenPtr + parsePtr->numTokens; destPtr->type = TCL_TOKEN_SUB_EXPR; destPtr->start = start-closer; destPtr->size = scanned+2*closer; destPtr->numComponents = 1; destPtr++; destPtr->type = TCL_TOKEN_TEXT; destPtr->start = start; destPtr->size = scanned; destPtr->numComponents = 0; parsePtr->numTokens += 2; return (start + scanned + closer - script); } /* *---------------------------------------------------------------------- * * CopyTokens -- * * Results: * Number of bytes scanned. * * Side effects: * The Tcl_Parse *parsePtr is filled with Tcl_Tokens representing the * literal. * *---------------------------------------------------------------------- */ static int CopyTokens( Tcl_Token *sourcePtr, Tcl_Parse *parsePtr) { int toCopy = sourcePtr->numComponents + 1; Tcl_Token *destPtr; if (sourcePtr->numComponents == sourcePtr[1].numComponents + 1) { while (parsePtr->numTokens + toCopy - 1 >= parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } destPtr = parsePtr->tokenPtr + parsePtr->numTokens; memcpy(destPtr, sourcePtr, (size_t) toCopy * sizeof(Tcl_Token)); destPtr->type = TCL_TOKEN_SUB_EXPR; parsePtr->numTokens += toCopy; } else { while (parsePtr->numTokens + toCopy >= parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } destPtr = parsePtr->tokenPtr + parsePtr->numTokens; *destPtr = *sourcePtr; destPtr->type = TCL_TOKEN_SUB_EXPR; destPtr->numComponents++; destPtr++; memcpy(destPtr, sourcePtr, (size_t) toCopy * sizeof(Tcl_Token)); parsePtr->numTokens += toCopy + 1; } return toCopy; } /* *---------------------------------------------------------------------- * * ConvertTreeToTokens -- * * Results: * None. * * Side effects: * The Tcl_Parse *parsePtr is filled with Tcl_Tokens representing the * parsed expression. * *---------------------------------------------------------------------- */ static void ConvertTreeToTokens( Tcl_Interp *interp, const char *start, int numBytes, OpNode *nodes, Tcl_Obj *litList, Tcl_Token *tokenPtr, Tcl_Parse *parsePtr) { OpNode *nodePtr = nodes; int nextLiteral = 0; int scanned, copied, tokenIdx; unsigned char lexeme; Tcl_Token *destPtr; while (1) { switch (NODE_TYPE & nodePtr->lexeme) { case UNARY: if (nodePtr->right > OT_NONE) { int right = nodePtr->right; nodePtr->right = OT_NONE; if (nodePtr->lexeme != START) { /* * Find operator in string. */ scanned = TclParseAllWhiteSpace(start, numBytes); start +=scanned; numBytes -= scanned; scanned = ParseLexeme(start, numBytes, &lexeme, NULL); if (lexeme != nodePtr->lexeme) { if (lexeme != (nodePtr->lexeme & ~NODE_TYPE)) { Tcl_Panic("lexeme mismatch"); } } if (nodePtr->lexeme != OPEN_PAREN) { if (parsePtr->numTokens + 1 >= parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } nodePtr->right = OT_NONE - parsePtr->numTokens; destPtr = parsePtr->tokenPtr + parsePtr->numTokens; destPtr->type = TCL_TOKEN_SUB_EXPR; destPtr->start = start; destPtr++; destPtr->type = TCL_TOKEN_OPERATOR; destPtr->start = start; destPtr->size = scanned; destPtr->numComponents = 0; parsePtr->numTokens += 2; } start +=scanned; numBytes -= scanned; } switch (right) { case OT_EMPTY: break; case OT_LITERAL: scanned = GenerateTokensForLiteral(start, numBytes, litList, nextLiteral++, parsePtr); start +=scanned; numBytes -= scanned; break; case OT_TOKENS: copied = CopyTokens(tokenPtr, parsePtr); scanned = tokenPtr->start + tokenPtr->size - start; start +=scanned; numBytes -= scanned; tokenPtr += copied; break; default: nodePtr = nodes + right; } } else { if (nodePtr->lexeme == START) { /* * We're done. */ return; } if (nodePtr->lexeme == OPEN_PAREN) { /* * Skip past matching close paren. */ scanned = TclParseAllWhiteSpace(start, numBytes); start +=scanned; numBytes -= scanned; scanned = ParseLexeme(start, numBytes, &lexeme, NULL); start +=scanned; numBytes -= scanned; } else { tokenIdx = OT_NONE - nodePtr->right; nodePtr->right = OT_NONE; destPtr = parsePtr->tokenPtr + tokenIdx; destPtr->size = start - destPtr->start; destPtr->numComponents = parsePtr->numTokens - tokenIdx - 1; } nodePtr = nodes + nodePtr->parent; } break; case BINARY: if (nodePtr->left > OT_NONE) { int left = nodePtr->left; nodePtr->left = OT_NONE; scanned = TclParseAllWhiteSpace(start, numBytes); start +=scanned; numBytes -= scanned; if ((nodePtr->lexeme != COMMA) && (nodePtr->lexeme != COLON)) { if (parsePtr->numTokens + 1 >= parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } nodePtr->left = OT_NONE - parsePtr->numTokens; destPtr = parsePtr->tokenPtr + parsePtr->numTokens; destPtr->type = TCL_TOKEN_SUB_EXPR; destPtr->start = start; destPtr++; destPtr->type = TCL_TOKEN_OPERATOR; parsePtr->numTokens += 2; } switch (left) { case OT_LITERAL: scanned = GenerateTokensForLiteral(start, numBytes, litList, nextLiteral++, parsePtr); start +=scanned; numBytes -= scanned; break; case OT_TOKENS: copied = CopyTokens(tokenPtr, parsePtr); scanned = tokenPtr->start + tokenPtr->size - start; start +=scanned; numBytes -= scanned; tokenPtr += copied; break; default: nodePtr = nodes + left; } } else if (nodePtr->right > OT_NONE) { int right = nodePtr->right; nodePtr->right = OT_NONE; scanned = TclParseAllWhiteSpace(start, numBytes); start +=scanned; numBytes -= scanned; scanned = ParseLexeme(start, numBytes, &lexeme, NULL); if (lexeme != nodePtr->lexeme) { if (lexeme != (nodePtr->lexeme & ~NODE_TYPE)) { Tcl_Panic("lexeme mismatch"); } } if ((nodePtr->lexeme != COMMA) && (nodePtr->lexeme != COLON)) { tokenIdx = OT_NONE - nodePtr->left; destPtr = parsePtr->tokenPtr + tokenIdx + 1; destPtr->start = start; destPtr->size = scanned; destPtr->numComponents = 0; } start +=scanned; numBytes -= scanned; switch (right) { case OT_LITERAL: scanned = GenerateTokensForLiteral(start, numBytes, litList, nextLiteral++, parsePtr); start +=scanned; numBytes -= scanned; break; case OT_TOKENS: copied = CopyTokens(tokenPtr, parsePtr); scanned = tokenPtr->start + tokenPtr->size - start; start +=scanned; numBytes -= scanned; tokenPtr += copied; break; default: nodePtr = nodes + right; } } else { if ((nodePtr->lexeme != COMMA) && (nodePtr->lexeme != COLON)) { tokenIdx = OT_NONE - nodePtr->left; nodePtr->left = OT_NONE; destPtr = parsePtr->tokenPtr + tokenIdx; destPtr->size = start - destPtr->start; destPtr->numComponents = parsePtr->numTokens-tokenIdx-1; } nodePtr = nodes + nodePtr->parent; } break; } } } #endif /* *---------------------------------------------------------------------- * * 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. */ { #ifndef PARSE_DIRECT_EXPR_TOKENS OpNode *opTree = NULL; /* Will point to the tree of operators */ Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals */ Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names*/ Tcl_Parse parse; /* Holds the Tcl_Tokens of substitutions */ int code = ParseExpr(interp, start, numBytes, &opTree, litList, funcList, &parse); if (numBytes < 0) { numBytes = (start ? strlen(start) : 0); } TclParseInit(interp, start, numBytes, parsePtr); if (code == TCL_OK) { ConvertTreeToTokens(interp, start, numBytes, opTree, litList, parse.tokenPtr, parsePtr); } else { /* TODO: copy over any error info to *parsePtr */ } Tcl_FreeParse(&parse); Tcl_DecrRefCount(funcList); Tcl_DecrRefCount(litList); ckfree((char *) opTree); return code; #else #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[] = { 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) { TclNewLiteralStringObj(msg, "not enough memory to parse expression"); code = TCL_ERROR; continue; } nodesAvailable = size; if (nodes == NULL) { memcpy(newPtr, 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), NULL); /* * Use context to categorize the lexemes that are ambiguous. */ if ((NODE_TYPE & nodePtr->lexeme) == 0) { switch (nodePtr->lexeme) { case INVALID: msg = Tcl_ObjPrintf( "invalid character \"%.*s\"", scanned, start); code = TCL_ERROR; continue; case INCOMPLETE: msg = Tcl_ObjPrintf( "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 = Tcl_ObjPrintf( "invalid bareword \"%.*s%s\"", (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "..."); post = Tcl_ObjPrintf( "should be \"$%.*s%s\" or \"{%.*s%s}\"", (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "...", (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "..."); Tcl_AppendPrintfToObj(post, " or \"%.*s%s(...)\" or ...", (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "..."); 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 = Tcl_ObjPrintf("missing operator at %s", mark); if (operand[0] == '0') { Tcl_Obj *copy = Tcl_NewStringObj(operand, start + scanned - operand); if (TclCheckBadOctal(NULL, Tcl_GetString(copy))) { TclNewLiteralStringObj(post, "looks like invalid octal number"); } 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) { TclNewLiteralStringObj(msg, "invalid character \"$\""); 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) { TclNewLiteralStringObj(msg, "missing close-bracket"); 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 = Tcl_ObjPrintf("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 = Tcl_ObjPrintf("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) { TclNewLiteralStringObj(msg, "unbalanced open paren"); } else if (lastNodePtr->lexeme == COMMA) { msg = Tcl_ObjPrintf( "missing function argument at %s", mark); scanned = 0; insertMark = 1; } else if (lastNodePtr->lexeme == START) { TclNewLiteralStringObj(msg, "empty expression"); } } else if (nodePtr->lexeme == CLOSE_PAREN) { TclNewLiteralStringObj(msg, "unbalanced close paren"); } else if ((nodePtr->lexeme == COMMA) && (lastNodePtr->lexeme == OPEN_PAREN) && (lastNodePtr[-1].lexeme == FUNCTION)) { msg = Tcl_ObjPrintf( "missing function argument at %s", mark); scanned = 0; insertMark = 1; } if (msg == NULL) { msg = Tcl_ObjPrintf("missing operand at %s", mark); scanned = 0; insertMark = 1; } 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; TclNewLiteralStringObj(msg, "unbalanced open paren"); code = TCL_ERROR; break; } if ((otherPtr->lexeme == QUESTION) && (lastOrphanPtr->lexeme != COLON)) { msg = Tcl_ObjPrintf( "missing operator \":\" at %s", mark); scanned = 0; insertMark = 1; code = TCL_ERROR; break; } if ((lastOrphanPtr->lexeme == COLON) && (otherPtr->lexeme != QUESTION)) { TclNewLiteralStringObj(msg, "unexpected operator \":\" without preceding \"?\""); 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) { TclNewLiteralStringObj(msg, "unbalanced close paren"); 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))) { TclNewLiteralStringObj(msg, "unexpected \",\" outside function argument list"); code = TCL_ERROR; continue; } if (lastOrphanPtr->lexeme == COLON) { TclNewLiteralStringObj(msg, "unexpected operator \":\" without preceding \"?\""); 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); } Tcl_AppendPrintfToObj(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; Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\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; #endif } #ifdef PARSE_DIRECT_EXPR_TOKENS /* *---------------------------------------------------------------------- * * 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(destPtr, 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(destPtr, sourcePtr, (size_t) (toCopy * sizeof(Tcl_Token))); parsePtr->numTokens += toCopy; break; } nodePtr = nodes + nodePtr->parent; break; } } } #endif /* *---------------------------------------------------------------------- * * 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. */ Tcl_Obj **literalPtr) /* Write corresponding literal value to this storage, if non-NULL. */ { const char *end; int scanned; Tcl_UniChar ch; Tcl_Obj *literal = NULL; 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; } } } literal = Tcl_NewObj(); if (TclParseNumber(NULL, literal, NULL, start, numBytes, &end, TCL_PARSE_NO_WHITESPACE) == TCL_OK) { TclInitStringRep(literal, start, end-start); *lexemePtr = NUMBER; if (literalPtr) { *literalPtr = literal; } else { Tcl_DecrRefCount(literal); } 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; Tcl_DecrRefCount(literal); return scanned; } end = start; while (isalnum(UCHAR(ch)) || (UCHAR(ch) == '_')) { end += scanned; numBytes -= scanned; if (Tcl_UtfCharComplete(end, numBytes)) { scanned = Tcl_UtfToUniChar(end, &ch); } else { char utfBytes[TCL_UTF_MAX]; memcpy(utfBytes, end, (size_t) numBytes); utfBytes[numBytes] = '\0'; scanned = Tcl_UtfToUniChar(utfBytes, &ch); } } *lexemePtr = BAREWORD; if (literalPtr) { Tcl_SetStringObj(literal, start, (int) (end-start)); *literalPtr = literal; } else { Tcl_DecrRefCount(literal); } return (end-start); } #ifdef USE_EXPR_TOKENS /* * Boolean variable that controls whether expression compilation tracing is * enabled. */ #ifdef TCL_COMPILE_DEBUG static int traceExprComp = 0; #endif /* TCL_COMPILE_DEBUG */ /* * Definitions of numeric codes representing each expression operator. The * order of these must match the entries in the operatorTable below. Also the * codes for the relational operators (OP_LESS, OP_GREATER, OP_LE, OP_GE, * OP_EQ, and OP_NE) must be consecutive and in that order. Note that OP_PLUS * and OP_MINUS represent both unary and binary operators. */ #define OP_MULT 0 #define OP_DIVIDE 1 #define OP_MOD 2 #define OP_PLUS 3 #define OP_MINUS 4 #define OP_LSHIFT 5 #define OP_RSHIFT 6 #define OP_LESS 7 #define OP_GREATER 8 #define OP_LE 9 #define OP_GE 10 #define OP_EQ 11 #define OP_NEQ 12 #define OP_BITAND 13 #define OP_BITXOR 14 #define OP_BITOR 15 #define OP_LAND 16 #define OP_LOR 17 #define OP_QUESTY 18 #define OP_LNOT 19 #define OP_BITNOT 20 #define OP_STREQ 21 #define OP_STRNEQ 22 #define OP_EXPON 23 #define OP_IN_LIST 24 #define OP_NOT_IN_LIST 25 /* * Table describing the expression operators. Entries in this table must * correspond to the definitions of numeric codes for operators just above. */ static int opTableInitialized = 0; /* 0 means not yet initialized. */ TCL_DECLARE_MUTEX(opMutex) typedef struct OperatorDesc { const char *name; /* Name of the operator. */ int numOperands; /* Number of operands. 0 if the operator * requires special handling. */ int instruction; /* Instruction opcode for the operator. * Ignored if numOperands is 0. */ } OperatorDesc; static OperatorDesc operatorTable[] = { {"*", 2, INST_MULT}, {"/", 2, INST_DIV}, {"%", 2, INST_MOD}, {"+", 0}, {"-", 0}, {"<<", 2, INST_LSHIFT}, {">>", 2, INST_RSHIFT}, {"<", 2, INST_LT}, {">", 2, INST_GT}, {"<=", 2, INST_LE}, {">=", 2, INST_GE}, {"==", 2, INST_EQ}, {"!=", 2, INST_NEQ}, {"&", 2, INST_BITAND}, {"^", 2, INST_BITXOR}, {"|", 2, INST_BITOR}, {"&&", 0}, {"||", 0}, {"?", 0}, {"!", 1, INST_LNOT}, {"~", 1, INST_BITNOT}, {"eq", 2, INST_STR_EQ}, {"ne", 2, INST_STR_NEQ}, {"**", 2, INST_EXPON}, {"in", 2, INST_LIST_IN}, {"ni", 2, INST_LIST_NOT_IN}, {NULL} }; /* * Hashtable used to map the names of expression operators to the index of * their OperatorDesc description. */ static Tcl_HashTable opHashTable; #endif /* USE_EXPR_TOKENS */ /* * Declarations for local procedures to this file: */ #ifdef USE_EXPR_TOKENS static void CompileCondExpr(Tcl_Interp *interp, Tcl_Token *exprTokenPtr, int *convertPtr, CompileEnv *envPtr); static void CompileLandOrLorExpr(Tcl_Interp *interp, Tcl_Token *exprTokenPtr, int opIndex, CompileEnv *envPtr); static void CompileMathFuncCall(Tcl_Interp *interp, Tcl_Token *exprTokenPtr, const char *funcName, CompileEnv *envPtr); static void CompileSubExpr(Tcl_Interp *interp, Tcl_Token *exprTokenPtr, int *convertPtr, CompileEnv *envPtr); #endif /* USE_EXPR_TOKENS */ static void CompileExprTree(Tcl_Interp *interp, OpNode *nodes, Tcl_Obj *const litObjv[], Tcl_Obj *funcList, Tcl_Token *tokenPtr, int *convertPtr, CompileEnv *envPtr); /* * Macro used to debug the execution of the expression compiler. */ #ifdef TCL_COMPILE_DEBUG #define TRACE(exprBytes, exprLength, tokenBytes, tokenLength) \ if (traceExprComp) { \ fprintf(stderr, "CompileSubExpr: \"%.*s\", token \"%.*s\"\n", \ (exprLength), (exprBytes), (tokenLength), (tokenBytes)); \ } #else #define TRACE(exprBytes, exprLength, tokenBytes, tokenLength) #endif /* TCL_COMPILE_DEBUG */ /* *---------------------------------------------------------------------- * * TclCompileExpr -- * * This procedure compiles a string containing a Tcl expression into Tcl * bytecodes. This procedure is the top-level interface to the the * expression compilation module, and is used by such public procedures * as Tcl_ExprString, Tcl_ExprStringObj, Tcl_ExprLong, Tcl_ExprDouble, * Tcl_ExprBoolean, and Tcl_ExprBooleanObj. * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR * on failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * Side effects: * Adds instructions to envPtr to evaluate the expression at runtime. * *---------------------------------------------------------------------- */ int TclCompileExpr( Tcl_Interp *interp, /* Used for error reporting. */ const char *script, /* The source script to compile. */ int numBytes, /* Number of bytes in script. If < 0, the * string consists of all bytes up to the * first null character. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { #ifndef USE_EXPR_TOKENS OpNode *opTree = NULL; /* Will point to the tree of operators */ Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals */ Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names*/ Tcl_Parse parse; /* Holds the Tcl_Tokens of substitutions */ int code = ParseExpr(interp, script, numBytes, &opTree, litList, funcList, &parse); if (code == TCL_OK) { int litObjc, needsNumConversion = 1; Tcl_Obj **litObjv; /* TIP #280 : Track Lines within the expression */ TclAdvanceLines(&envPtr->line, script, script + TclParseAllWhiteSpace(script, numBytes)); /* * Valid parse; compile the tree. */ Tcl_ListObjGetElements(NULL, litList, &litObjc, &litObjv); CompileExprTree(interp, opTree, litObjv, funcList, parse.tokenPtr, &needsNumConversion, envPtr); if (needsNumConversion) { /* * Attempt to convert the expression result to an int or double. * This is done in order to support Tcl's policy of interpreting * operands if at all possible as first integers, else * floating-point numbers. */ TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); } } Tcl_FreeParse(&parse); Tcl_DecrRefCount(funcList); Tcl_DecrRefCount(litList); ckfree((char *) opTree); return code; #else Tcl_Parse parse; int needsNumConversion = 1; /* * If this is the first time we've been called, initialize the table of * expression operators. */ if (numBytes < 0) { numBytes = (script? strlen(script) : 0); } if (!opTableInitialized) { Tcl_MutexLock(&opMutex); if (!opTableInitialized) { int i; Tcl_InitHashTable(&opHashTable, TCL_STRING_KEYS); for (i = 0; operatorTable[i].name != NULL; i++) { int new; Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&opHashTable, operatorTable[i].name, &new); if (new) { Tcl_SetHashValue(hPtr, (ClientData) INT2PTR(i)); } } opTableInitialized = 1; } Tcl_MutexUnlock(&opMutex); } /* * Parse the expression then compile it. */ if (TCL_OK != Tcl_ParseExpr(interp, script, numBytes, &parse)) { return TCL_ERROR; } /* TIP #280 : Track Lines within the expression */ TclAdvanceLines (&envPtr->line, script, parse.tokenPtr->start); CompileSubExpr(interp, parse.tokenPtr, &needsNumConversion, envPtr); if (needsNumConversion) { /* * Attempt to convert the primary's object to an int or double. This * is done in order to support Tcl's policy of interpreting operands * if at all possible as first integers, else floating-point numbers. */ TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); } Tcl_FreeParse(&parse); return TCL_OK; #endif } /* *---------------------------------------------------------------------- * * CompileExprTree -- * [???] * * Results: * None. * * Side effects: * Adds instructions to envPtr to evaluate the expression at runtime. * *---------------------------------------------------------------------- */ typedef struct JumpList { JumpFixup jump; int depth; int offset; int convert; struct JumpList *next; } JumpList; static void CompileExprTree( Tcl_Interp *interp, OpNode *nodes, Tcl_Obj *const litObjv[], Tcl_Obj *funcList, Tcl_Token *tokenPtr, int *convertPtr, CompileEnv *envPtr) { OpNode *nodePtr = nodes; int nextFunc = 0; JumpList *freePtr, *jumpPtr = NULL; static const int instruction[] = { 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, INST_ADD, INST_SUB, 0, /* COMMA */ INST_MULT, INST_DIV, INST_MOD, INST_LT, INST_GT, INST_BITAND, INST_BITXOR, INST_BITOR, 0, /* QUESTION */ 0, /* COLON */ INST_LSHIFT, INST_RSHIFT, INST_LE, INST_GE, INST_EQ, INST_NEQ, 0, /* AND */ 0, /* OR */ INST_STR_EQ, INST_STR_NEQ, INST_EXPON, INST_LIST_IN, INST_LIST_NOT_IN, 0, /* CLOSE_PAREN */ 0, /* END */ 0, 0, 0, 0, INST_UPLUS, INST_UMINUS, 0, /* FUNCTION */ 0, /* START */ 0, /* OPEN_PAREN */ INST_LNOT, INST_BITNOT }; while (1) { switch (NODE_TYPE & nodePtr->lexeme) { case UNARY: if (nodePtr->right > OT_NONE) { int right = nodePtr->right; nodePtr->right = OT_NONE; if (nodePtr->lexeme == FUNCTION) { Tcl_DString cmdName; Tcl_Obj *funcName; const char *p; int length; Tcl_DStringInit(&cmdName); Tcl_DStringAppend(&cmdName, "tcl::mathfunc::", -1); Tcl_ListObjIndex(NULL, funcList, nextFunc++, &funcName); p = Tcl_GetStringFromObj(funcName, &length); Tcl_DStringAppend(&cmdName, p, length); TclEmitPush(TclRegisterNewNSLiteral(envPtr, Tcl_DStringValue(&cmdName), Tcl_DStringLength(&cmdName)), envPtr); Tcl_DStringFree(&cmdName); } switch (right) { case OT_EMPTY: break; case OT_LITERAL: /* TODO: reduce constant expressions */ TclEmitPush( TclAddLiteralObj( envPtr, *litObjv++, NULL), envPtr); break; case OT_TOKENS: if (tokenPtr->type != TCL_TOKEN_WORD) { Tcl_Panic("unexpected token type %d\n", tokenPtr->type); } TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); tokenPtr += tokenPtr->numComponents + 1; break; default: nodePtr = nodes + right; } } else { if (nodePtr->lexeme == START) { /* We're done */ return; } if (nodePtr->lexeme == OPEN_PAREN) { /* do nothing */ } else if (nodePtr->lexeme == FUNCTION) { int numWords = (nodePtr[1].left - OT_NONE) + 1; if (numWords < 255) { TclEmitInstInt1(INST_INVOKE_STK1, numWords, envPtr); } else { TclEmitInstInt4(INST_INVOKE_STK4, numWords, envPtr); } *convertPtr = 1; } else { TclEmitOpcode(instruction[nodePtr->lexeme], envPtr); *convertPtr = 0; } nodePtr = nodes + nodePtr->parent; } break; case BINARY: if (nodePtr->left > OT_NONE) { int left = nodePtr->left; nodePtr->left = OT_NONE; /* TODO: reduce constant expressions */ if (nodePtr->lexeme == QUESTION) { JumpList *newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; jumpPtr->depth = envPtr->currStackDepth; *convertPtr = 1; } else if (nodePtr->lexeme == AND || nodePtr->lexeme == OR) { JumpList *newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; newJump = (JumpList *) TclStackAlloc(interp, sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; jumpPtr->depth = envPtr->currStackDepth; } switch (left) { case OT_LITERAL: TclEmitPush(TclAddLiteralObj(envPtr, *litObjv++, NULL), envPtr); break; case OT_TOKENS: if (tokenPtr->type != TCL_TOKEN_WORD) { Tcl_Panic("unexpected token type %d\n", tokenPtr->type); } TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); tokenPtr += tokenPtr->numComponents + 1; break; default: nodePtr = nodes + left; } } else if (nodePtr->right > OT_NONE) { int right = nodePtr->right; nodePtr->right = OT_NONE; if (nodePtr->lexeme == QUESTION) { TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &(jumpPtr->jump)); } else if (nodePtr->lexeme == COLON) { TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &(jumpPtr->next->jump)); envPtr->currStackDepth = jumpPtr->depth; jumpPtr->offset = (envPtr->codeNext - envPtr->codeStart); jumpPtr->convert = *convertPtr; *convertPtr = 1; } else if (nodePtr->lexeme == AND) { TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &(jumpPtr->jump)); } else if (nodePtr->lexeme == OR) { TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &(jumpPtr->jump)); } switch (right) { case OT_LITERAL: TclEmitPush(TclAddLiteralObj(envPtr, *litObjv++, NULL), envPtr); break; case OT_TOKENS: if (tokenPtr->type != TCL_TOKEN_WORD) { Tcl_Panic("unexpected token type %d\n", tokenPtr->type); } TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); tokenPtr += tokenPtr->numComponents + 1; break; default: nodePtr = nodes + right; } } else { if (nodePtr->lexeme == COMMA || nodePtr->lexeme == QUESTION) { /* do nothing */ } else if (nodePtr->lexeme == COLON) { if (TclFixupForwardJump(envPtr, &(jumpPtr->next->jump), (envPtr->codeNext - envPtr->codeStart) - jumpPtr->next->jump.codeOffset, 127)) { jumpPtr->offset += 3; } TclFixupForwardJump(envPtr, &(jumpPtr->jump), jumpPtr->offset - jumpPtr->jump.codeOffset, 127); *convertPtr |= jumpPtr->convert; envPtr->currStackDepth = jumpPtr->depth + 1; freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); } else if (nodePtr->lexeme == AND) { TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &(jumpPtr->next->jump)); TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr); } else if (nodePtr->lexeme == OR) { TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &(jumpPtr->next->jump)); TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr); } else { TclEmitOpcode(instruction[nodePtr->lexeme], envPtr); *convertPtr = 0; } if ((nodePtr->lexeme == AND) || (nodePtr->lexeme == OR)) { TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &(jumpPtr->next->next->jump)); TclFixupForwardJumpToHere(envPtr, &(jumpPtr->next->jump), 127); if (TclFixupForwardJumpToHere(envPtr, &(jumpPtr->jump), 127)) { jumpPtr->next->next->jump.codeOffset += 3; } TclEmitPush(TclRegisterNewLiteral(envPtr, (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr); TclFixupForwardJumpToHere(envPtr, &(jumpPtr->next->next->jump), 127); *convertPtr = 0; envPtr->currStackDepth = jumpPtr->depth + 1; freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); } nodePtr = nodes + nodePtr->parent; } break; } } } static int OpCmd( Tcl_Interp *interp, OpNode *nodes, Tcl_Obj * const litObjv[]) { CompileEnv *compEnvPtr; ByteCode *byteCodePtr; int code, tmp=1; Tcl_Obj *byteCodeObj = Tcl_NewObj(); /* * Note we are compiling an expression with literal arguments. This means * there can be no [info frame] calls when we execute the resulting * bytecode, so there's no need to tend to TIP 280 issues. */ compEnvPtr = (CompileEnv *) TclStackAlloc(interp, sizeof(CompileEnv)); TclInitCompileEnv(interp, compEnvPtr, NULL, 0, NULL, 0); CompileExprTree(interp, nodes, litObjv, NULL, NULL, &tmp, compEnvPtr); TclEmitOpcode(INST_DONE, compEnvPtr); Tcl_IncrRefCount(byteCodeObj); TclInitByteCodeObj(byteCodeObj, compEnvPtr); TclFreeCompileEnv(compEnvPtr); TclStackFree(interp, compEnvPtr); byteCodePtr = (ByteCode *) byteCodeObj->internalRep.otherValuePtr; code = TclExecuteByteCode(interp, byteCodePtr); Tcl_DecrRefCount(byteCodeObj); return code; } int TclSingleOpCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData; unsigned char lexeme; OpNode nodes[2]; if (objc != 1+occdPtr->numArgs) { Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected); return TCL_ERROR; } ParseLexeme(occdPtr->operator, strlen(occdPtr->operator), &lexeme, NULL); nodes[0].lexeme = START; nodes[0].right = 1; nodes[1].lexeme = lexeme; nodes[1].left = OT_LITERAL; nodes[1].right = OT_LITERAL; nodes[1].parent = 0; return OpCmd(interp, nodes, objv+1); } int TclSortingOpCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { int code = TCL_OK; if (objc < 3) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); } else { TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData; Tcl_Obj **litObjv = (Tcl_Obj **) TclStackAlloc(interp, 2*(objc-2)*sizeof(Tcl_Obj *)); OpNode *nodes = (OpNode *) TclStackAlloc(interp, 2*(objc-2)*sizeof(OpNode)); unsigned char lexeme; int i, lastAnd = 1; ParseLexeme(occdPtr->operator, strlen(occdPtr->operator), &lexeme, NULL); litObjv[0] = objv[1]; nodes[0].lexeme = START; for (i=2; inumArgs)); return TCL_OK; } ParseLexeme(occdPtr->operator, strlen(occdPtr->operator), &lexeme, NULL); lexeme |= BINARY; if (objc == 2) { Tcl_Obj *litObjv[2]; OpNode nodes[2]; int decrMe = 0; if (lexeme == EXPON) { litObjv[1] = Tcl_NewIntObj(occdPtr->numArgs); Tcl_IncrRefCount(litObjv[1]); decrMe = 1; litObjv[0] = objv[1]; nodes[0].lexeme = START; nodes[0].right = 1; nodes[1].lexeme = lexeme; nodes[1].left = OT_LITERAL; nodes[1].right = OT_LITERAL; nodes[1].parent = 0; } else { if (lexeme == DIVIDE) { litObjv[0] = Tcl_NewDoubleObj(1.0); } else { litObjv[0] = Tcl_NewIntObj(occdPtr->numArgs); } Tcl_IncrRefCount(litObjv[0]); litObjv[1] = objv[1]; nodes[0].lexeme = START; nodes[0].right = 1; nodes[1].lexeme = lexeme; nodes[1].left = OT_LITERAL; nodes[1].right = OT_LITERAL; nodes[1].parent = 0; } code = OpCmd(interp, nodes, litObjv); Tcl_DecrRefCount(litObjv[decrMe]); return code; } else { OpNode *nodes = (OpNode *) TclStackAlloc(interp, (objc-1)*sizeof(OpNode)); int i, lastOp = OT_LITERAL; nodes[0].lexeme = START; if (lexeme == EXPON) { for (i=objc-2; i>0; i-- ) { nodes[i].lexeme = lexeme; nodes[i].left = OT_LITERAL; nodes[i].right = lastOp; if (lastOp >= 0) { nodes[lastOp].parent = i; } lastOp = i; } } else { for (i=1; i= 0) { nodes[lastOp].parent = i; } nodes[i].right = OT_LITERAL; lastOp = i; } } nodes[0].right = lastOp; nodes[lastOp].parent = 0; code = OpCmd(interp, nodes, objv+1); TclStackFree(interp, nodes); return code; } } int TclNoIdentOpCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected); return TCL_ERROR; } return TclVariadicOpCmd(clientData, interp, objc, objv); } /* *---------------------------------------------------------------------- * * TclFinalizeCompilation -- * * Clean up the compilation environment so it can later be properly * reinitialized. This procedure is called by Tcl_Finalize(). * * Results: * None. * * Side effects: * Cleans up the compilation environment. At the moment, just the table * of expression operators is freed. * *---------------------------------------------------------------------- */ void TclFinalizeCompilation(void) { #ifdef USE_EXPR_TOKENS Tcl_MutexLock(&opMutex); if (opTableInitialized) { Tcl_DeleteHashTable(&opHashTable); opTableInitialized = 0; } Tcl_MutexUnlock(&opMutex); #endif } #ifdef USE_EXPR_TOKENS /* *---------------------------------------------------------------------- * * CompileSubExpr -- * * Given a pointer to a TCL_TOKEN_SUB_EXPR token describing a * subexpression, this procedure emits instructions to evaluate the * subexpression at runtime. * * Results: * None. * * Side effects: * Adds instructions to envPtr to evaluate the subexpression. * *---------------------------------------------------------------------- */ static void CompileSubExpr( Tcl_Interp *interp, /* Interp in which to compile expression */ Tcl_Token *exprTokenPtr, /* Points to TCL_TOKEN_SUB_EXPR token to * compile. */ int *convertPtr, /* Writes 0 here if it is determined the * final INST_TRY_CVT_TO_NUMERIC is * not needed */ CompileEnv *envPtr) /* Holds resulting instructions. */ { /* * Switch on the type of the first token after the subexpression token. */ Tcl_Token *tokenPtr = exprTokenPtr+1; TRACE(exprTokenPtr->start, exprTokenPtr->size, tokenPtr->start, tokenPtr->size); switch (tokenPtr->type) { case TCL_TOKEN_WORD: TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); break; case TCL_TOKEN_TEXT: TclEmitPush(TclRegisterNewLiteral(envPtr, tokenPtr->start, tokenPtr->size), envPtr); break; case TCL_TOKEN_BS: { char buffer[TCL_UTF_MAX]; int length = Tcl_UtfBackslash(tokenPtr->start, NULL, buffer); TclEmitPush(TclRegisterNewLiteral(envPtr, buffer, length), envPtr); break; } case TCL_TOKEN_COMMAND: TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, envPtr); break; case TCL_TOKEN_VARIABLE: TclCompileTokens(interp, tokenPtr, 1, envPtr); break; case TCL_TOKEN_SUB_EXPR: CompileSubExpr(interp, tokenPtr, convertPtr, envPtr); break; case TCL_TOKEN_OPERATOR: { /* * Look up the operator. If the operator isn't found, treat it as a * math function. */ OperatorDesc *opDescPtr; Tcl_HashEntry *hPtr; const char *operator; Tcl_DString opBuf; int opIndex; Tcl_DStringInit(&opBuf); operator = Tcl_DStringAppend(&opBuf, tokenPtr->start, tokenPtr->size); hPtr = Tcl_FindHashEntry(&opHashTable, operator); if (hPtr == NULL) { CompileMathFuncCall(interp, exprTokenPtr, operator, envPtr); Tcl_DStringFree(&opBuf); break; } Tcl_DStringFree(&opBuf); opIndex = PTR2INT(Tcl_GetHashValue(hPtr)); opDescPtr = &(operatorTable[opIndex]); /* * If the operator is "normal", compile it using information from the * operator table. */ if (opDescPtr->numOperands > 0) { tokenPtr++; CompileSubExpr(interp, tokenPtr, convertPtr, envPtr); tokenPtr += (tokenPtr->numComponents + 1); if (opDescPtr->numOperands == 2) { CompileSubExpr(interp, tokenPtr, convertPtr, envPtr); } TclEmitOpcode(opDescPtr->instruction, envPtr); *convertPtr = 0; break; } /* * The operator requires special treatment, and is either "+" or "-", * or one of "&&", "||" or "?". */ switch (opIndex) { case OP_PLUS: case OP_MINUS: { Tcl_Token *afterSubexprPtr = exprTokenPtr + exprTokenPtr->numComponents+1; tokenPtr++; CompileSubExpr(interp, tokenPtr, convertPtr, envPtr); tokenPtr += (tokenPtr->numComponents + 1); /* * Check whether the "+" or "-" is unary. */ if (tokenPtr == afterSubexprPtr) { TclEmitOpcode(((opIndex==OP_PLUS)? INST_UPLUS : INST_UMINUS), envPtr); break; } /* * The "+" or "-" is binary. */ CompileSubExpr(interp, tokenPtr, convertPtr, envPtr); TclEmitOpcode(((opIndex==OP_PLUS)? INST_ADD : INST_SUB), envPtr); *convertPtr = 0; break; } case OP_LAND: case OP_LOR: CompileLandOrLorExpr(interp, exprTokenPtr, opIndex, envPtr); *convertPtr = 0; break; case OP_QUESTY: CompileCondExpr(interp, exprTokenPtr, convertPtr, envPtr); break; default: Tcl_Panic("CompileSubExpr: unexpected operator %d " "requiring special treatment", opIndex); } /* end switch on operator requiring special treatment */ break; } default: Tcl_Panic("CompileSubExpr: unexpected token type %d", tokenPtr->type); } } /* *---------------------------------------------------------------------- * * CompileLandOrLorExpr -- * * This procedure compiles a Tcl logical and ("&&") or logical or ("||") * subexpression. * * Results: * None. * * Side effects: * Adds instructions to envPtr to evaluate the expression at runtime. * *---------------------------------------------------------------------- */ static void CompileLandOrLorExpr( Tcl_Interp *interp, /* Interp in which compile takes place */ Tcl_Token *exprTokenPtr, /* Points to TCL_TOKEN_SUB_EXPR token * containing the "&&" or "||" operator. */ int opIndex, /* A code describing the expression operator: * either OP_LAND or OP_LOR. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { JumpFixup shortCircuitFixup;/* Used to fix up the short circuit jump after * the first subexpression. */ JumpFixup shortCircuitFixup2; /* Used to fix up the second jump to the * short-circuit target. */ JumpFixup endFixup; /* Used to fix up jump to the end. */ int convert = 0; int savedStackDepth = envPtr->currStackDepth; Tcl_Token *tokenPtr = exprTokenPtr+2; /* * Emit code for the first operand. */ CompileSubExpr(interp, tokenPtr, &convert, envPtr); tokenPtr += (tokenPtr->numComponents + 1); /* * Emit the short-circuit jump. */ TclEmitForwardJump(envPtr, ((opIndex==OP_LAND)? TCL_FALSE_JUMP : TCL_TRUE_JUMP), &shortCircuitFixup); /* * Emit code for the second operand. */ CompileSubExpr(interp, tokenPtr, &convert, envPtr); /* * The result is the boolean value of the second operand. We code this in * a somewhat contorted manner to be able to reuse the shortCircuit value * and save one INST_JUMP. */ TclEmitForwardJump(envPtr, ((opIndex==OP_LAND)? TCL_FALSE_JUMP : TCL_TRUE_JUMP), &shortCircuitFixup2); if (opIndex == OP_LAND) { TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr); } else { TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr); } TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup); /* * Fixup the short-circuit jumps and push the shortCircuit value. Note * that shortCircuitFixup2 is always a short jump. */ TclFixupForwardJumpToHere(envPtr, &shortCircuitFixup2, 127); if (TclFixupForwardJumpToHere(envPtr, &shortCircuitFixup, 127)) { /* * shortCircuit jump grown by 3 bytes: update endFixup. */ endFixup.codeOffset += 3; } if (opIndex == OP_LAND) { TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr); } else { TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr); } TclFixupForwardJumpToHere(envPtr, &endFixup, 127); envPtr->currStackDepth = savedStackDepth + 1; } /* *---------------------------------------------------------------------- * * CompileCondExpr -- * * This procedure compiles a Tcl conditional expression: * condExpr ::= lorExpr ['?' condExpr ':' condExpr] * * Results: * None. * * Side effects: * Adds instructions to envPtr to evaluate the expression at runtime. * *---------------------------------------------------------------------- */ static void CompileCondExpr( Tcl_Interp *interp, /* Interp in which compile takes place */ Tcl_Token *exprTokenPtr, /* Points to TCL_TOKEN_SUB_EXPR token * containing the "?" operator. */ int *convertPtr, /* Describes the compilation state for the * expression being compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { JumpFixup jumpAroundThenFixup, jumpAroundElseFixup; /* Used to update or replace one-byte jumps * around the then and else expressions when * their target PCs are determined. */ Tcl_Token *tokenPtr = exprTokenPtr+2; int elseCodeOffset, dist, convert = 0; int convertThen = 1, convertElse = 1; int savedStackDepth = envPtr->currStackDepth; /* * Emit code for the test. */ CompileSubExpr(interp, tokenPtr, &convert, envPtr); tokenPtr += (tokenPtr->numComponents + 1); /* * Emit the jump to the "else" expression if the test was false. */ TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpAroundThenFixup); /* * Compile the "then" expression. Note that if a subexpression is only a * primary, we need to try to convert it to numeric. We do this to support * Tcl's policy of interpreting operands if at all possible as first * integers, else floating-point numbers. */ CompileSubExpr(interp, tokenPtr, &convertThen, envPtr); tokenPtr += (tokenPtr->numComponents + 1); /* * Emit an unconditional jump around the "else" condExpr. */ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpAroundElseFixup); /* * Compile the "else" expression. */ envPtr->currStackDepth = savedStackDepth; elseCodeOffset = (envPtr->codeNext - envPtr->codeStart); CompileSubExpr(interp, tokenPtr, &convertElse, envPtr); /* * Fix up the second jump around the "else" expression. */ dist = (envPtr->codeNext - envPtr->codeStart) - jumpAroundElseFixup.codeOffset; if (TclFixupForwardJump(envPtr, &jumpAroundElseFixup, dist, 127)) { /* * Update the else expression's starting code offset since it moved * down 3 bytes too. */ elseCodeOffset += 3; } /* * Fix up the first jump to the "else" expression if the test was false. */ dist = (elseCodeOffset - jumpAroundThenFixup.codeOffset); TclFixupForwardJump(envPtr, &jumpAroundThenFixup, dist, 127); *convertPtr = convertThen || convertElse; envPtr->currStackDepth = savedStackDepth + 1; } /* *---------------------------------------------------------------------- * * CompileMathFuncCall -- * * This procedure compiles a call on a math function in an expression: * mathFuncCall ::= funcName '(' [condExpr {',' condExpr}] ')' * * Results: * None. * * Side effects: * Adds instructions to envPtr to evaluate the math function at * runtime. * *---------------------------------------------------------------------- */ static void CompileMathFuncCall( Tcl_Interp *interp, /* Interp in which compile takes place */ Tcl_Token *exprTokenPtr, /* Points to TCL_TOKEN_SUB_EXPR token * containing the math function call. */ const char *funcName, /* Name of the math function. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_DString cmdName; int objIndex; Tcl_Token *tokenPtr, *afterSubexprPtr; int argCount; /* * Prepend "tcl::mathfunc::" to the function name, to produce the name of * a command that evaluates the function. Push that command name on the * stack, in a literal registered to the namespace so that resolution can * be cached. */ Tcl_DStringInit(&cmdName); Tcl_DStringAppend(&cmdName, "tcl::mathfunc::", -1); Tcl_DStringAppend(&cmdName, funcName, -1); objIndex = TclRegisterNewNSLiteral(envPtr, Tcl_DStringValue(&cmdName), Tcl_DStringLength(&cmdName)); TclEmitPush(objIndex, envPtr); Tcl_DStringFree(&cmdName); /* * Compile any arguments for the function. */ argCount = 1; tokenPtr = exprTokenPtr+2; afterSubexprPtr = exprTokenPtr + (exprTokenPtr->numComponents + 1); while (tokenPtr != afterSubexprPtr) { int convert = 0; ++argCount; CompileSubExpr(interp, tokenPtr, &convert, envPtr); tokenPtr += (tokenPtr->numComponents + 1); } /* * Invoke the function. */ if (argCount < 255) { TclEmitInstInt1(INST_INVOKE_STK1, argCount, envPtr); } else { TclEmitInstInt4(INST_INVOKE_STK4, argCount, envPtr); } } #endif /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */