/*
* tclCompExpr.c --
*
* This file contains the code to compile Tcl expressions.
*
* Copyright (c) 1997 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 by Scriptics Corporation.
*
* 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.13 2003/02/16 01:36:32 msofer Exp $
*/
#include "tclInt.h"
#include "tclCompile.h"
/*
* The stuff below is a bit of a hack so that this file can be used in
* environments that include no UNIX, i.e. no errno: just arrange to use
* the errno from tclExecute.c here.
*/
#ifndef TCL_GENERIC_ONLY
#include "tclPort.h"
#else
#define NO_ERRNO_H
#endif
#ifdef NO_ERRNO_H
extern int errno; /* Use errno from tclExecute.c. */
#define ERANGE 34
#endif
/*
* Boolean variable that controls whether expression compilation tracing
* is enabled.
*/
#ifdef TCL_COMPILE_DEBUG
static int traceExprComp = 0;
#endif /* TCL_COMPILE_DEBUG */
/*
* The ExprInfo structure describes the state of compiling an expression.
* A pointer to an ExprInfo record is passed among the routines in
* this module.
*/
typedef struct ExprInfo {
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Structure filled with information about
* the parsed expression. */
CONST char *expr; /* The expression that was originally passed
* to TclCompileExpr. */
CONST char *lastChar; /* Points just after last byte of expr. */
int hasOperators; /* Set 1 if the expr has operators; 0 if
* expr is only a primary. If 1 after
* compiling an expr, a tryCvtToNumeric
* instruction is emitted to convert the
* primary to a number if possible. */
} ExprInfo;
/*
* 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
/*
* 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 {
char *name; /* Name of the operator. */
int numOperands; /* Number of operands. 0 if the operator
* requires special handling. */
int instruction; /* Instruction opcode for the operator.
* Ignored if numOperands is 0. */
} OperatorDesc;
static OperatorDesc operatorTable[] = {
{"*", 2, INST_MULT},
{"/", 2, INST_DIV},
{"%", 2, INST_MOD},
{"+", 0},
{"-", 0},
{"<<", 2, INST_LSHIFT},
{">>", 2, INST_RSHIFT},
{"<", 2, INST_LT},
{">", 2, INST_GT},
{"<=", 2, INST_LE},
{">=", 2, INST_GE},
{"==", 2, INST_EQ},
{"!=", 2, INST_NEQ},
{"&", 2, INST_BITAND},
{"^", 2, INST_BITXOR},
{"|", 2, INST_BITOR},
{"&&", 0},
{"||", 0},
{"?", 0},
{"!", 1, INST_LNOT},
{"~", 1, INST_BITNOT},
{"eq", 2, INST_STR_EQ},
{"ne", 2, INST_STR_NEQ},
{NULL}
};
/*
* Hashtable used to map the names of expression operators to the index
* of their OperatorDesc description.
*/
static Tcl_HashTable opHashTable;
/*
* Declarations for local procedures to this file:
*/
static int CompileCondExpr _ANSI_ARGS_((
Tcl_Token *exprTokenPtr, ExprInfo *infoPtr,
CompileEnv *envPtr, Tcl_Token **endPtrPtr));
static int CompileLandOrLorExpr _ANSI_ARGS_((
Tcl_Token *exprTokenPtr, int opIndex,
ExprInfo *infoPtr, CompileEnv *envPtr,
Tcl_Token **endPtrPtr));
static int CompileMathFuncCall _ANSI_ARGS_((
Tcl_Token *exprTokenPtr, CONST char *funcName,
ExprInfo *infoPtr, CompileEnv *envPtr,
Tcl_Token **endPtrPtr));
static int CompileSubExpr _ANSI_ARGS_((
Tcl_Token *exprTokenPtr, ExprInfo *infoPtr,
CompileEnv *envPtr));
static void LogSyntaxError _ANSI_ARGS_((ExprInfo *infoPtr));
/*
* 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(interp, script, numBytes, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
CONST char *script; /* The source script to compile. */
int numBytes; /* Number of bytes in script. If < 0, the
* string consists of all bytes up to the
* first null character. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
ExprInfo info;
Tcl_Parse parse;
Tcl_HashEntry *hPtr;
int new, i, code;
/*
* 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) {
Tcl_InitHashTable(&opHashTable, TCL_STRING_KEYS);
for (i = 0; operatorTable[i].name != NULL; i++) {
hPtr = Tcl_CreateHashEntry(&opHashTable,
operatorTable[i].name, &new);
if (new) {
Tcl_SetHashValue(hPtr, (ClientData) i);
}
}
opTableInitialized = 1;
}
Tcl_MutexUnlock(&opMutex);
}
/*
* Initialize the structure containing information abvout this
* expression compilation.
*/
info.interp = interp;
info.parsePtr = &parse;
info.expr = script;
info.lastChar = (script + numBytes);
info.hasOperators = 0;
/*
* Parse the expression then compile it.
*/
code = Tcl_ParseExpr(interp, script, numBytes, &parse);
if (code != TCL_OK) {
goto done;
}
code = CompileSubExpr(parse.tokenPtr, &info, envPtr);
if (code != TCL_OK) {
Tcl_FreeParse(&parse);
goto done;
}
if (!info.hasOperators) {
/*
* 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);
done:
return code;
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeCompilation --
*
* Clean up the compilation environment so it can later be
* properly reinitialized. This procedure is called by
* TclFinalizeCompExecEnv() in tclObj.c, which in turn 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()
{
Tcl_MutexLock(&opMutex);
if (opTableInitialized) {
Tcl_DeleteHashTable(&opHashTable);
opTableInitialized = 0;
}
Tcl_MutexUnlock(&opMutex);
}
/*
*----------------------------------------------------------------------
*
* 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:
* 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 subexpression.
*
*----------------------------------------------------------------------
*/
static int
CompileSubExpr(exprTokenPtr, infoPtr, envPtr)
Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token
* to compile. */
ExprInfo *infoPtr; /* Describes the compilation state for the
* expression being compiled. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Interp *interp = infoPtr->interp;
Tcl_Token *tokenPtr, *endPtr, *afterSubexprPtr;
OperatorDesc *opDescPtr;
Tcl_HashEntry *hPtr;
CONST char *operator;
Tcl_DString opBuf;
int objIndex, opIndex, length, code;
char buffer[TCL_UTF_MAX];
if (exprTokenPtr->type != TCL_TOKEN_SUB_EXPR) {
panic("CompileSubExpr: token type %d not TCL_TOKEN_SUB_EXPR\n",
exprTokenPtr->type);
}
code = TCL_OK;
/*
* Switch on the type of the first token after the subexpression token.
* After processing it, advance tokenPtr to point just after the
* subexpression's last token.
*/
tokenPtr = exprTokenPtr+1;
TRACE(exprTokenPtr->start, exprTokenPtr->size,
tokenPtr->start, tokenPtr->size);
switch (tokenPtr->type) {
case TCL_TOKEN_WORD:
code = TclCompileTokens(interp, tokenPtr+1,
tokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
break;
case TCL_TOKEN_TEXT:
if (tokenPtr->size > 0) {
objIndex = TclRegisterNewLiteral(envPtr, tokenPtr->start,
tokenPtr->size);
} else {
objIndex = TclRegisterNewLiteral(envPtr, "", 0);
}
TclEmitPush(objIndex, envPtr);
tokenPtr += 1;
break;
case TCL_TOKEN_BS:
length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
buffer);
if (length > 0) {
objIndex = TclRegisterNewLiteral(envPtr, buffer, length);
} else {
objIndex = TclRegisterNewLiteral(envPtr, "", 0);
}
TclEmitPush(objIndex, envPtr);
tokenPtr += 1;
break;
case TCL_TOKEN_COMMAND:
code = TclCompileScript(interp, tokenPtr->start+1,
tokenPtr->size-2, /*nested*/ 0, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += 1;
break;
case TCL_TOKEN_VARIABLE:
code = TclCompileTokens(interp, tokenPtr, 1, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
break;
case TCL_TOKEN_SUB_EXPR:
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
break;
case TCL_TOKEN_OPERATOR:
/*
* Look up the operator. If the operator isn't found, treat it
* as a math function.
*/
Tcl_DStringInit(&opBuf);
operator = Tcl_DStringAppend(&opBuf,
tokenPtr->start, tokenPtr->size);
hPtr = Tcl_FindHashEntry(&opHashTable, operator);
if (hPtr == NULL) {
code = CompileMathFuncCall(exprTokenPtr, operator, infoPtr,
envPtr, &endPtr);
Tcl_DStringFree(&opBuf);
if (code != TCL_OK) {
goto done;
}
tokenPtr = endPtr;
break;
}
Tcl_DStringFree(&opBuf);
opIndex = (int) Tcl_GetHashValue(hPtr);
opDescPtr = &(operatorTable[opIndex]);
/*
* If the operator is "normal", compile it using information
* from the operator table.
*/
if (opDescPtr->numOperands > 0) {
tokenPtr++;
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
if (opDescPtr->numOperands == 2) {
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
}
TclEmitOpcode(opDescPtr->instruction, envPtr);
infoPtr->hasOperators = 1;
break;
}
/*
* The operator requires special treatment, and is either
* "+" or "-", or one of "&&", "||" or "?".
*/
switch (opIndex) {
case OP_PLUS:
case OP_MINUS:
tokenPtr++;
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
/*
* Check whether the "+" or "-" is unary.
*/
afterSubexprPtr = exprTokenPtr
+ exprTokenPtr->numComponents+1;
if (tokenPtr == afterSubexprPtr) {
TclEmitOpcode(((opIndex==OP_PLUS)?
INST_UPLUS : INST_UMINUS),
envPtr);
break;
}
/*
* The "+" or "-" is binary.
*/
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
TclEmitOpcode(((opIndex==OP_PLUS)? INST_ADD : INST_SUB),
envPtr);
break;
case OP_LAND:
case OP_LOR:
code = CompileLandOrLorExpr(exprTokenPtr, opIndex,
infoPtr, envPtr, &endPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr = endPtr;
break;
case OP_QUESTY:
code = CompileCondExpr(exprTokenPtr, infoPtr,
envPtr, &endPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr = endPtr;
break;
default:
panic("CompileSubExpr: unexpected operator %d requiring special treatment\n",
opIndex);
} /* end switch on operator requiring special treatment */
infoPtr->hasOperators = 1;
break;
default:
panic("CompileSubExpr: unexpected token type %d\n",
tokenPtr->type);
}
/*
* Verify that the subexpression token had the required number of
* subtokens: that we've advanced tokenPtr just beyond the
* subexpression's last token. For example, a "*" subexpression must
* contain the tokens for exactly two operands.
*/
if (tokenPtr != (exprTokenPtr + exprTokenPtr->numComponents+1)) {
LogSyntaxError(infoPtr);
code = TCL_ERROR;
}
done:
return code;
}
/*
*----------------------------------------------------------------------
*
* CompileLandOrLorExpr --
*
* This procedure compiles a Tcl logical and ("&&") or logical or
* ("||") subexpression.
*
* Results:
* The return value is TCL_OK on a successful compilation and TCL_ERROR
* on failure. If TCL_OK is returned, a pointer to the token just after
* the last one in the subexpression is stored at the address in
* endPtrPtr. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* Side effects:
* Adds instructions to envPtr to evaluate the expression at runtime.
*
*----------------------------------------------------------------------
*/
static int
CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, endPtrPtr)
Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token
* containing the "&&" or "||" operator. */
int opIndex; /* A code describing the expression
* operator: either OP_LAND or OP_LOR. */
ExprInfo *infoPtr; /* Describes the compilation state for the
* expression being compiled. */
CompileEnv *envPtr; /* Holds resulting instructions. */
Tcl_Token **endPtrPtr; /* If successful, a pointer to the token
* just after the last token in the
* subexpression is stored here. */
{
JumpFixup shortCircuitFixup; /* Used to fix up the short circuit jump
* after the first subexpression. */
JumpFixup lhsTrueFixup, lhsEndFixup;
/* Used to fix up jumps used to convert the
* first operand to 0 or 1. */
Tcl_Token *tokenPtr;
int dist, code;
int savedStackDepth = envPtr->currStackDepth;
/*
* Emit code for the first operand.
*/
tokenPtr = exprTokenPtr+2;
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
/*
* Convert the first operand to the result that Tcl requires:
* "0" or "1". Eventually we'll use a new instruction for this.
*/
TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &lhsTrueFixup);
TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr);
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &lhsEndFixup);
dist = (envPtr->codeNext - envPtr->codeStart) - lhsTrueFixup.codeOffset;
if (TclFixupForwardJump(envPtr, &lhsTrueFixup, dist, 127)) {
badDist:
panic("CompileLandOrLorExpr: bad jump distance %d\n", dist);
}
envPtr->currStackDepth = savedStackDepth;
TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr);
dist = (envPtr->codeNext - envPtr->codeStart) - lhsEndFixup.codeOffset;
if (TclFixupForwardJump(envPtr, &lhsEndFixup, dist, 127)) {
goto badDist;
}
/*
* Emit the "short circuit" jump around the rest of the expression.
* Duplicate the "0" or "1" on top of the stack first to keep the
* jump from consuming it.
*/
TclEmitOpcode(INST_DUP, envPtr);
TclEmitForwardJump(envPtr,
((opIndex==OP_LAND)? TCL_FALSE_JUMP : TCL_TRUE_JUMP),
&shortCircuitFixup);
/*
* Emit code for the second operand.
*/
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
/*
* Emit a "logical and" or "logical or" instruction. This does not try
* to "short- circuit" the evaluation of both operands, but instead
* ensures that we either have a "1" or a "0" result.
*/
TclEmitOpcode(((opIndex==OP_LAND)? INST_LAND : INST_LOR), envPtr);
/*
* Now that we know the target of the forward jump, update it with the
* correct distance.
*/
dist = (envPtr->codeNext - envPtr->codeStart)
- shortCircuitFixup.codeOffset;
TclFixupForwardJump(envPtr, &shortCircuitFixup, dist, 127);
*endPtrPtr = tokenPtr;
done:
envPtr->currStackDepth = savedStackDepth + 1;
return code;
}
/*
*----------------------------------------------------------------------
*
* CompileCondExpr --
*
* This procedure compiles a Tcl conditional expression:
* condExpr ::= lorExpr ['?' condExpr ':' condExpr]
*
* Results:
* The return value is TCL_OK on a successful compilation and TCL_ERROR
* on failure. If TCL_OK is returned, a pointer to the token just after
* the last one in the subexpression is stored at the address in
* endPtrPtr. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* Side effects:
* Adds instructions to envPtr to evaluate the expression at runtime.
*
*----------------------------------------------------------------------
*/
static int
CompileCondExpr(exprTokenPtr, infoPtr, envPtr, endPtrPtr)
Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token
* containing the "?" operator. */
ExprInfo *infoPtr; /* Describes the compilation state for the
* expression being compiled. */
CompileEnv *envPtr; /* Holds resulting instructions. */
Tcl_Token **endPtrPtr; /* If successful, a pointer to the token
* just after the last token in the
* subexpression is stored here. */
{
JumpFixup jumpAroundThenFixup, jumpAroundElseFixup;
/* Used to update or replace one-byte jumps
* around the then and else expressions when
* their target PCs are determined. */
Tcl_Token *tokenPtr;
int elseCodeOffset, dist, code;
int savedStackDepth = envPtr->currStackDepth;
/*
* Emit code for the test.
*/
tokenPtr = exprTokenPtr+2;
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
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.
*/
infoPtr->hasOperators = 0;
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
if (!infoPtr->hasOperators) {
TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
}
/*
* 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);
infoPtr->hasOperators = 0;
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
if (!infoPtr->hasOperators) {
TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
}
/*
* 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);
*endPtrPtr = tokenPtr;
done:
envPtr->currStackDepth = savedStackDepth + 1;
return code;
}
/*
*----------------------------------------------------------------------
*
* CompileMathFuncCall --
*
* This procedure compiles a call on a math function in an expression:
* mathFuncCall ::= funcName '(' [condExpr {',' condExpr}] ')'
*
* Results:
* The return value is TCL_OK on a successful compilation and TCL_ERROR
* on failure. If TCL_OK is returned, a pointer to the token just after
* the last one in the subexpression is stored at the address in
* endPtrPtr. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* Side effects:
* Adds instructions to envPtr to evaluate the math function at
* runtime.
*
*----------------------------------------------------------------------
*/
static int
CompileMathFuncCall(exprTokenPtr, funcName, infoPtr, envPtr, endPtrPtr)
Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token
* containing the math function call. */
CONST char *funcName; /* Name of the math function. */
ExprInfo *infoPtr; /* Describes the compilation state for the
* expression being compiled. */
CompileEnv *envPtr; /* Holds resulting instructions. */
Tcl_Token **endPtrPtr; /* If successful, a pointer to the token
* just after the last token in the
* subexpression is stored here. */
{
Tcl_Interp *interp = infoPtr->interp;
Interp *iPtr = (Interp *) interp;
MathFunc *mathFuncPtr;
Tcl_HashEntry *hPtr;
Tcl_Token *tokenPtr, *afterSubexprPtr;
int code, i;
/*
* Look up the MathFunc record for the function.
*/
code = TCL_OK;
hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
if (hPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"unknown math function \"", funcName, "\"", (char *) NULL);
code = TCL_ERROR;
goto done;
}
mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
/*
* If not a builtin function, push an object with the function's name.
*/
if (mathFuncPtr->builtinFuncIndex < 0) {
TclEmitPush(TclRegisterNewLiteral(envPtr, funcName, -1), envPtr);
}
/*
* Compile any arguments for the function.
*/
tokenPtr = exprTokenPtr+2;
afterSubexprPtr = exprTokenPtr + (exprTokenPtr->numComponents + 1);
if (mathFuncPtr->numArgs > 0) {
for (i = 0; i < mathFuncPtr->numArgs; i++) {
if (tokenPtr == afterSubexprPtr) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"too few arguments for math function", -1);
code = TCL_ERROR;
goto done;
}
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
}
if (tokenPtr != afterSubexprPtr) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"too many arguments for math function", -1);
code = TCL_ERROR;
goto done;
}
} else if (tokenPtr != afterSubexprPtr) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"too many arguments for math function", -1);
code = TCL_ERROR;
goto done;
}
/*
* Compile the call on the math function. Note that the "objc" argument
* count for non-builtin functions is incremented by 1 to include the
* function name itself.
*/
if (mathFuncPtr->builtinFuncIndex >= 0) { /* a builtin function */
/*
* Adjust the current stack depth by the number of arguments
* of the builtin function. This cannot be handled by the
* TclEmitInstInt1 macro as the number of arguments is not
* passed as an operand.
*/
if (envPtr->maxStackDepth < envPtr->currStackDepth) {
envPtr->maxStackDepth = envPtr->currStackDepth;
}
TclEmitInstInt1(INST_CALL_BUILTIN_FUNC1,
mathFuncPtr->builtinFuncIndex, envPtr);
envPtr->currStackDepth -= mathFuncPtr->numArgs;
} else {
TclEmitInstInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr);
}
*endPtrPtr = afterSubexprPtr;
done:
return code;
}
/*
*----------------------------------------------------------------------
*
* LogSyntaxError --
*
* This procedure is invoked after an error occurs when compiling an
* expression. It sets the interpreter result to an error message
* describing the error.
*
* Results:
* None.
*
* Side effects:
* Sets the interpreter result to an error message describing the
* expression that was being compiled when the error occurred.
*
*----------------------------------------------------------------------
*/
static void
LogSyntaxError(infoPtr)
ExprInfo *infoPtr; /* Describes the compilation state for the
* expression being compiled. */
{
int numBytes = (infoPtr->lastChar - infoPtr->expr);
char buffer[100];
sprintf(buffer, "syntax error in expression \"%.*s\"",
((numBytes > 60)? 60 : numBytes), infoPtr->expr);
Tcl_ResetResult(infoPtr->interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
buffer, (char *) NULL);
}