diff options
Diffstat (limited to 'contrib/tcl/generic/tclExpr.c')
| -rw-r--r-- | contrib/tcl/generic/tclExpr.c | 2055 |
1 files changed, 2055 insertions, 0 deletions
diff --git a/contrib/tcl/generic/tclExpr.c b/contrib/tcl/generic/tclExpr.c new file mode 100644 index 0000000..13d020f --- /dev/null +++ b/contrib/tcl/generic/tclExpr.c @@ -0,0 +1,2055 @@ +/* + * tclExpr.c -- + * + * This file contains the code to evaluate expressions for + * Tcl. + * + * This implementation of floating-point support was modelled + * after an initial implementation by Bill Carpenter. + * + * Copyright (c) 1987-1994 The Regents of the University of California. + * Copyright (c) 1994 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclExpr.c 1.91 96/02/15 11:42:44 + */ + +#include "tclInt.h" +#ifdef NO_FLOAT_H +# include "../compat/float.h" +#else +# include <float.h> +#endif +#ifndef TCL_NO_MATH +#include <math.h> +#endif + +/* + * 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 define + * errno here. + */ + +#ifndef TCL_GENERIC_ONLY +#include "tclPort.h" +#else +#define NO_ERRNO_H +#endif + +#ifdef NO_ERRNO_H +int errno; +#define EDOM 33 +#define ERANGE 34 +#endif + +/* + * The data structure below is used to describe an expression value, + * which can be either an integer (the usual case), a double-precision + * floating-point value, or a string. A given number has only one + * value at a time. + */ + +#define STATIC_STRING_SPACE 150 + +typedef struct { + long intValue; /* Integer value, if any. */ + double doubleValue; /* Floating-point value, if any. */ + ParseValue pv; /* Used to hold a string value, if any. */ + char staticSpace[STATIC_STRING_SPACE]; + /* Storage for small strings; large ones + * are malloc-ed. */ + int type; /* Type of value: TYPE_INT, TYPE_DOUBLE, + * or TYPE_STRING. */ +} Value; + +/* + * Valid values for type: + */ + +#define TYPE_INT 0 +#define TYPE_DOUBLE 1 +#define TYPE_STRING 2 + +/* + * The data structure below describes the state of parsing an expression. + * It's passed among the routines in this module. + */ + +typedef struct { + char *originalExpr; /* The entire expression, as originally + * passed to Tcl_ExprString et al. */ + char *expr; /* Position to the next character to be + * scanned from the expression string. */ + int token; /* Type of the last token to be parsed from + * expr. See below for definitions. + * Corresponds to the characters just + * before expr. */ +} ExprInfo; + +/* + * The token types are defined below. In addition, there is a table + * associating a precedence with each operator. The order of types + * is important. Consult the code before changing it. + */ + +#define VALUE 0 +#define OPEN_PAREN 1 +#define CLOSE_PAREN 2 +#define COMMA 3 +#define END 4 +#define UNKNOWN 5 + +/* + * Binary operators: + */ + +#define MULT 8 +#define DIVIDE 9 +#define MOD 10 +#define PLUS 11 +#define MINUS 12 +#define LEFT_SHIFT 13 +#define RIGHT_SHIFT 14 +#define LESS 15 +#define GREATER 16 +#define LEQ 17 +#define GEQ 18 +#define EQUAL 19 +#define NEQ 20 +#define BIT_AND 21 +#define BIT_XOR 22 +#define BIT_OR 23 +#define AND 24 +#define OR 25 +#define QUESTY 26 +#define COLON 27 + +/* + * Unary operators: + */ + +#define UNARY_MINUS 28 +#define UNARY_PLUS 29 +#define NOT 30 +#define BIT_NOT 31 + +/* + * Precedence table. The values for non-operator token types are ignored. + */ + +static int precTable[] = { + 0, 0, 0, 0, 0, 0, 0, 0, + 12, 12, 12, /* MULT, DIVIDE, MOD */ + 11, 11, /* PLUS, MINUS */ + 10, 10, /* LEFT_SHIFT, RIGHT_SHIFT */ + 9, 9, 9, 9, /* LESS, GREATER, LEQ, GEQ */ + 8, 8, /* EQUAL, NEQ */ + 7, /* BIT_AND */ + 6, /* BIT_XOR */ + 5, /* BIT_OR */ + 4, /* AND */ + 3, /* OR */ + 2, /* QUESTY */ + 1, /* COLON */ + 13, 13, 13, 13 /* UNARY_MINUS, UNARY_PLUS, NOT, + * BIT_NOT */ +}; + +/* + * Mapping from operator numbers to strings; used for error messages. + */ + +static char *operatorStrings[] = { + "VALUE", "(", ")", ",", "END", "UNKNOWN", "6", "7", + "*", "/", "%", "+", "-", "<<", ">>", "<", ">", "<=", + ">=", "==", "!=", "&", "^", "|", "&&", "||", "?", ":", + "-", "+", "!", "~" +}; + +/* + * The following slight modification to DBL_MAX is needed because of + * a compiler bug on Sprite (4/15/93). + */ + +#ifdef sprite +#undef DBL_MAX +#define DBL_MAX 1.797693134862316e+307 +#endif + +/* + * Macros for testing floating-point values for certain special + * cases. Test for not-a-number by comparing a value against + * itself; test for infinity by comparing against the largest + * floating-point value. + */ + +#define IS_NAN(v) ((v) != (v)) +#ifdef DBL_MAX +# define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX)) +#else +# define IS_INF(v) 0 +#endif + +/* + * The following global variable is use to signal matherr that Tcl + * is responsible for the arithmetic, so errors can be handled in a + * fashion appropriate for Tcl. Zero means no Tcl math is in + * progress; non-zero means Tcl is doing math. + */ + +int tcl_MathInProgress = 0; + +/* + * The variable below serves no useful purpose except to generate + * a reference to matherr, so that the Tcl version of matherr is + * linked in rather than the system version. Without this reference + * the need for matherr won't be discovered during linking until after + * libtcl.a has been processed, so Tcl's version won't be used. + */ + +#ifdef NEED_MATHERR +extern int matherr(); +int (*tclMatherrPtr)() = matherr; +#endif + +/* + * Declarations for local procedures to this file: + */ + +static int ExprAbsFunc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, + Tcl_Value *resultPtr)); +static int ExprBinaryFunc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, + Tcl_Value *resultPtr)); +static int ExprDoubleFunc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, + Tcl_Value *resultPtr)); +static int ExprGetValue _ANSI_ARGS_((Tcl_Interp *interp, + ExprInfo *infoPtr, int prec, Value *valuePtr)); +static int ExprIntFunc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, + Tcl_Value *resultPtr)); +static int ExprLex _ANSI_ARGS_((Tcl_Interp *interp, + ExprInfo *infoPtr, Value *valuePtr)); +static int ExprLooksLikeInt _ANSI_ARGS_((char *p)); +static void ExprMakeString _ANSI_ARGS_((Tcl_Interp *interp, + Value *valuePtr)); +static int ExprMathFunc _ANSI_ARGS_((Tcl_Interp *interp, + ExprInfo *infoPtr, Value *valuePtr)); +static int ExprParseString _ANSI_ARGS_((Tcl_Interp *interp, + char *string, Value *valuePtr)); +static int ExprRoundFunc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, + Tcl_Value *resultPtr)); +static int ExprTopLevel _ANSI_ARGS_((Tcl_Interp *interp, + char *string, Value *valuePtr)); +static int ExprUnaryFunc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, + Tcl_Value *resultPtr)); + +/* + * Built-in math functions: + */ + +typedef struct { + char *name; /* Name of function. */ + int numArgs; /* Number of arguments for function. */ + Tcl_ValueType argTypes[MAX_MATH_ARGS]; + /* Acceptable types for each argument. */ + Tcl_MathProc *proc; /* Procedure that implements this function. */ + ClientData clientData; /* Additional argument to pass to the function + * when invoking it. */ +} BuiltinFunc; + +static BuiltinFunc funcTable[] = { +#ifndef TCL_NO_MATH + {"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos}, + {"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin}, + {"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan}, + {"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2}, + {"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil}, + {"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos}, + {"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh}, + {"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp}, + {"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor}, + {"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod}, + {"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot}, + {"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log}, + {"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10}, + {"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow}, + {"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin}, + {"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh}, + {"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt}, + {"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan}, + {"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh}, +#endif + {"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0}, + {"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0}, + {"int", 1, {TCL_EITHER}, ExprIntFunc, 0}, + {"round", 1, {TCL_EITHER}, ExprRoundFunc, 0}, + + {0}, +}; + +/* + *-------------------------------------------------------------- + * + * ExprParseString -- + * + * Given a string (such as one coming from command or variable + * substitution), make a Value based on the string. The value + * will be a floating-point or integer, if possible, or else it + * will just be a copy of the string. + * + * Results: + * TCL_OK is returned under normal circumstances, and TCL_ERROR + * is returned if a floating-point overflow or underflow occurred + * while reading in a number. The value at *valuePtr is modified + * to hold a number, if possible. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +ExprParseString(interp, string, valuePtr) + Tcl_Interp *interp; /* Where to store error message. */ + char *string; /* String to turn into value. */ + Value *valuePtr; /* Where to store value information. + * Caller must have initialized pv field. */ +{ + char *term, *p, *start; + + if (*string != 0) { + if (ExprLooksLikeInt(string)) { + valuePtr->type = TYPE_INT; + errno = 0; + + /* + * Note: use strtoul instead of strtol for integer conversions + * to allow full-size unsigned numbers, but don't depend on + * strtoul to handle sign characters; it won't in some + * implementations. + */ + + for (p = string; isspace(UCHAR(*p)); p++) { + /* Empty loop body. */ + } + if (*p == '-') { + start = p+1; + valuePtr->intValue = -((int)strtoul(start, &term, 0)); + } else if (*p == '+') { + start = p+1; + valuePtr->intValue = strtoul(start, &term, 0); + } else { + start = p; + valuePtr->intValue = strtoul(start, &term, 0); + } + if (*term == 0) { + if (errno == ERANGE) { + /* + * This procedure is sometimes called with string in + * interp->result, so we have to clear the result before + * logging an error message. + */ + + Tcl_ResetResult(interp); + interp->result = "integer value too large to represent"; + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + interp->result, (char *) NULL); + return TCL_ERROR; + } else { + return TCL_OK; + } + } + } else { + errno = 0; + valuePtr->doubleValue = strtod(string, &term); + if ((term != string) && (*term == 0)) { + if (errno != 0) { + Tcl_ResetResult(interp); + TclExprFloatError(interp, valuePtr->doubleValue); + return TCL_ERROR; + } + valuePtr->type = TYPE_DOUBLE; + return TCL_OK; + } + } + } + + /* + * Not a valid number. Save a string value (but don't do anything + * if it's already the value). + */ + + valuePtr->type = TYPE_STRING; + if (string != valuePtr->pv.buffer) { + int length, shortfall; + + length = strlen(string); + valuePtr->pv.next = valuePtr->pv.buffer; + shortfall = length - (valuePtr->pv.end - valuePtr->pv.buffer); + if (shortfall > 0) { + (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall); + } + strcpy(valuePtr->pv.buffer, string); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ExprLex -- + * + * Lexical analyzer for expression parser: parses a single value, + * operator, or other syntactic element from an expression string. + * + * Results: + * TCL_OK is returned unless an error occurred while doing lexical + * analysis or executing an embedded command. In that case a + * standard Tcl error is returned, using interp->result to hold + * an error message. In the event of a successful return, the token + * and field in infoPtr is updated to refer to the next symbol in + * the expression string, and the expr field is advanced past that + * token; if the token is a value, then the value is stored at + * valuePtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ExprLex(interp, infoPtr, valuePtr) + Tcl_Interp *interp; /* Interpreter to use for error + * reporting. */ + register ExprInfo *infoPtr; /* Describes the state of the parse. */ + register Value *valuePtr; /* Where to store value, if that is + * what's parsed from string. Caller + * must have initialized pv field + * correctly. */ +{ + register char *p; + char *var, *term; + int result; + + p = infoPtr->expr; + while (isspace(UCHAR(*p))) { + p++; + } + if (*p == 0) { + infoPtr->token = END; + infoPtr->expr = p; + return TCL_OK; + } + + /* + * First try to parse the token as an integer or floating-point number. + * Don't want to check for a number if the first character is "+" + * or "-". If we do, we might treat a binary operator as unary by + * mistake, which will eventually cause a syntax error. + */ + + if ((*p != '+') && (*p != '-')) { + if (ExprLooksLikeInt(p)) { + errno = 0; + valuePtr->intValue = strtoul(p, &term, 0); + if (errno == ERANGE) { + interp->result = "integer value too large to represent"; + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + interp->result, (char *) NULL); + return TCL_ERROR; + } + infoPtr->token = VALUE; + infoPtr->expr = term; + valuePtr->type = TYPE_INT; + return TCL_OK; + } else { + errno = 0; + valuePtr->doubleValue = strtod(p, &term); + if (term != p) { + if (errno != 0) { + TclExprFloatError(interp, valuePtr->doubleValue); + return TCL_ERROR; + } + infoPtr->token = VALUE; + infoPtr->expr = term; + valuePtr->type = TYPE_DOUBLE; + return TCL_OK; + } + } + } + + infoPtr->expr = p+1; + switch (*p) { + case '$': + + /* + * Variable. Fetch its value, then see if it makes sense + * as an integer or floating-point number. + */ + + infoPtr->token = VALUE; + var = Tcl_ParseVar(interp, p, &infoPtr->expr); + if (var == NULL) { + return TCL_ERROR; + } + Tcl_ResetResult(interp); + if (((Interp *) interp)->noEval) { + valuePtr->type = TYPE_INT; + valuePtr->intValue = 0; + return TCL_OK; + } + return ExprParseString(interp, var, valuePtr); + + case '[': + infoPtr->token = VALUE; + ((Interp *) interp)->evalFlags = TCL_BRACKET_TERM; + result = Tcl_Eval(interp, p+1); + infoPtr->expr = ((Interp *) interp)->termPtr; + if (result != TCL_OK) { + return result; + } + infoPtr->expr++; + if (((Interp *) interp)->noEval) { + valuePtr->type = TYPE_INT; + valuePtr->intValue = 0; + Tcl_ResetResult(interp); + return TCL_OK; + } + result = ExprParseString(interp, interp->result, valuePtr); + if (result != TCL_OK) { + return result; + } + Tcl_ResetResult(interp); + return TCL_OK; + + case '"': + infoPtr->token = VALUE; + result = TclParseQuotes(interp, infoPtr->expr, '"', 0, + &infoPtr->expr, &valuePtr->pv); + if (result != TCL_OK) { + return result; + } + Tcl_ResetResult(interp); + return ExprParseString(interp, valuePtr->pv.buffer, valuePtr); + + case '{': + infoPtr->token = VALUE; + result = TclParseBraces(interp, infoPtr->expr, &infoPtr->expr, + &valuePtr->pv); + if (result != TCL_OK) { + return result; + } + Tcl_ResetResult(interp); + return ExprParseString(interp, valuePtr->pv.buffer, valuePtr); + + case '(': + infoPtr->token = OPEN_PAREN; + return TCL_OK; + + case ')': + infoPtr->token = CLOSE_PAREN; + return TCL_OK; + + case ',': + infoPtr->token = COMMA; + return TCL_OK; + + case '*': + infoPtr->token = MULT; + return TCL_OK; + + case '/': + infoPtr->token = DIVIDE; + return TCL_OK; + + case '%': + infoPtr->token = MOD; + return TCL_OK; + + case '+': + infoPtr->token = PLUS; + return TCL_OK; + + case '-': + infoPtr->token = MINUS; + return TCL_OK; + + case '?': + infoPtr->token = QUESTY; + return TCL_OK; + + case ':': + infoPtr->token = COLON; + return TCL_OK; + + case '<': + switch (p[1]) { + case '<': + infoPtr->expr = p+2; + infoPtr->token = LEFT_SHIFT; + break; + case '=': + infoPtr->expr = p+2; + infoPtr->token = LEQ; + break; + default: + infoPtr->token = LESS; + break; + } + return TCL_OK; + + case '>': + switch (p[1]) { + case '>': + infoPtr->expr = p+2; + infoPtr->token = RIGHT_SHIFT; + break; + case '=': + infoPtr->expr = p+2; + infoPtr->token = GEQ; + break; + default: + infoPtr->token = GREATER; + break; + } + return TCL_OK; + + case '=': + if (p[1] == '=') { + infoPtr->expr = p+2; + infoPtr->token = EQUAL; + } else { + infoPtr->token = UNKNOWN; + } + return TCL_OK; + + case '!': + if (p[1] == '=') { + infoPtr->expr = p+2; + infoPtr->token = NEQ; + } else { + infoPtr->token = NOT; + } + return TCL_OK; + + case '&': + if (p[1] == '&') { + infoPtr->expr = p+2; + infoPtr->token = AND; + } else { + infoPtr->token = BIT_AND; + } + return TCL_OK; + + case '^': + infoPtr->token = BIT_XOR; + return TCL_OK; + + case '|': + if (p[1] == '|') { + infoPtr->expr = p+2; + infoPtr->token = OR; + } else { + infoPtr->token = BIT_OR; + } + return TCL_OK; + + case '~': + infoPtr->token = BIT_NOT; + return TCL_OK; + + default: + if (isalpha(UCHAR(*p))) { + infoPtr->expr = p; + return ExprMathFunc(interp, infoPtr, valuePtr); + } + infoPtr->expr = p+1; + infoPtr->token = UNKNOWN; + return TCL_OK; + } +} + +/* + *---------------------------------------------------------------------- + * + * ExprGetValue -- + * + * Parse a "value" from the remainder of the expression in infoPtr. + * + * Results: + * Normally TCL_OK is returned. The value of the expression is + * returned in *valuePtr. If an error occurred, then interp->result + * contains an error message and TCL_ERROR is returned. + * InfoPtr->token will be left pointing to the token AFTER the + * expression, and infoPtr->expr will point to the character just + * after the terminating token. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ExprGetValue(interp, infoPtr, prec, valuePtr) + Tcl_Interp *interp; /* Interpreter to use for error + * reporting. */ + register ExprInfo *infoPtr; /* Describes the state of the parse + * just before the value (i.e. ExprLex + * will be called to get first token + * of value). */ + int prec; /* Treat any un-parenthesized operator + * with precedence <= this as the end + * of the expression. */ + Value *valuePtr; /* Where to store the value of the + * expression. Caller must have + * initialized pv field. */ +{ + Interp *iPtr = (Interp *) interp; + Value value2; /* Second operand for current + * operator. */ + int operator; /* Current operator (either unary + * or binary). */ + int badType; /* Type of offending argument; used + * for error messages. */ + int gotOp; /* Non-zero means already lexed the + * operator (while picking up value + * for unary operator). Don't lex + * again. */ + int result; + + /* + * There are two phases to this procedure. First, pick off an initial + * value. Then, parse (binary operator, value) pairs until done. + */ + + gotOp = 0; + value2.pv.buffer = value2.pv.next = value2.staticSpace; + value2.pv.end = value2.pv.buffer + STATIC_STRING_SPACE - 1; + value2.pv.expandProc = TclExpandParseValue; + value2.pv.clientData = (ClientData) NULL; + result = ExprLex(interp, infoPtr, valuePtr); + if (result != TCL_OK) { + goto done; + } + if (infoPtr->token == OPEN_PAREN) { + + /* + * Parenthesized sub-expression. + */ + + result = ExprGetValue(interp, infoPtr, -1, valuePtr); + if (result != TCL_OK) { + goto done; + } + if (infoPtr->token != CLOSE_PAREN) { + Tcl_AppendResult(interp, "unmatched parentheses in expression \"", + infoPtr->originalExpr, "\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + } else { + if (infoPtr->token == MINUS) { + infoPtr->token = UNARY_MINUS; + } + if (infoPtr->token == PLUS) { + infoPtr->token = UNARY_PLUS; + } + if (infoPtr->token >= UNARY_MINUS) { + + /* + * Process unary operators. + */ + + operator = infoPtr->token; + result = ExprGetValue(interp, infoPtr, precTable[infoPtr->token], + valuePtr); + if (result != TCL_OK) { + goto done; + } + if (!iPtr->noEval) { + switch (operator) { + case UNARY_MINUS: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue = -valuePtr->intValue; + } else if (valuePtr->type == TYPE_DOUBLE){ + valuePtr->doubleValue = -valuePtr->doubleValue; + } else { + badType = valuePtr->type; + goto illegalType; + } + break; + case UNARY_PLUS: + if ((valuePtr->type != TYPE_INT) + && (valuePtr->type != TYPE_DOUBLE)) { + badType = valuePtr->type; + goto illegalType; + } + break; + case NOT: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue = !valuePtr->intValue; + } else if (valuePtr->type == TYPE_DOUBLE) { + /* + * Theoretically, should be able to use + * "!valuePtr->intValue", but apparently some + * compilers can't handle it. + */ + if (valuePtr->doubleValue == 0.0) { + valuePtr->intValue = 1; + } else { + valuePtr->intValue = 0; + } + valuePtr->type = TYPE_INT; + } else { + badType = valuePtr->type; + goto illegalType; + } + break; + case BIT_NOT: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue = ~valuePtr->intValue; + } else { + badType = valuePtr->type; + goto illegalType; + } + break; + } + } + gotOp = 1; + } else if (infoPtr->token != VALUE) { + goto syntaxError; + } + } + + /* + * Got the first operand. Now fetch (operator, operand) pairs. + */ + + if (!gotOp) { + result = ExprLex(interp, infoPtr, &value2); + if (result != TCL_OK) { + goto done; + } + } + while (1) { + operator = infoPtr->token; + value2.pv.next = value2.pv.buffer; + if ((operator < MULT) || (operator >= UNARY_MINUS)) { + if ((operator == END) || (operator == CLOSE_PAREN) + || (operator == COMMA)) { + result = TCL_OK; + goto done; + } else { + goto syntaxError; + } + } + if (precTable[operator] <= prec) { + result = TCL_OK; + goto done; + } + + /* + * If we're doing an AND or OR and the first operand already + * determines the result, don't execute anything in the + * second operand: just parse. Same style for ?: pairs. + */ + + if ((operator == AND) || (operator == OR) || (operator == QUESTY)) { + if (valuePtr->type == TYPE_DOUBLE) { + valuePtr->intValue = valuePtr->doubleValue != 0; + valuePtr->type = TYPE_INT; + } else if (valuePtr->type == TYPE_STRING) { + if (!iPtr->noEval) { + badType = TYPE_STRING; + goto illegalType; + } + + /* + * Must set valuePtr->intValue to avoid referencing + * uninitialized memory in the "if" below; the atual + * value doesn't matter, since it will be ignored. + */ + + valuePtr->intValue = 0; + } + if (((operator == AND) && !valuePtr->intValue) + || ((operator == OR) && valuePtr->intValue)) { + iPtr->noEval++; + result = ExprGetValue(interp, infoPtr, precTable[operator], + &value2); + iPtr->noEval--; + if (operator == OR) { + valuePtr->intValue = 1; + } + continue; + } else if (operator == QUESTY) { + /* + * Special note: ?: operators must associate right to + * left. To make this happen, use a precedence one lower + * than QUESTY when calling ExprGetValue recursively. + */ + + if (valuePtr->intValue != 0) { + valuePtr->pv.next = valuePtr->pv.buffer; + result = ExprGetValue(interp, infoPtr, + precTable[QUESTY] - 1, valuePtr); + if (result != TCL_OK) { + goto done; + } + if (infoPtr->token != COLON) { + goto syntaxError; + } + value2.pv.next = value2.pv.buffer; + iPtr->noEval++; + result = ExprGetValue(interp, infoPtr, + precTable[QUESTY] - 1, &value2); + iPtr->noEval--; + } else { + iPtr->noEval++; + result = ExprGetValue(interp, infoPtr, + precTable[QUESTY] - 1, &value2); + iPtr->noEval--; + if (result != TCL_OK) { + goto done; + } + if (infoPtr->token != COLON) { + goto syntaxError; + } + valuePtr->pv.next = valuePtr->pv.buffer; + result = ExprGetValue(interp, infoPtr, + precTable[QUESTY] - 1, valuePtr); + } + continue; + } else { + result = ExprGetValue(interp, infoPtr, precTable[operator], + &value2); + } + } else { + result = ExprGetValue(interp, infoPtr, precTable[operator], + &value2); + } + if (result != TCL_OK) { + goto done; + } + if ((infoPtr->token < MULT) && (infoPtr->token != VALUE) + && (infoPtr->token != END) && (infoPtr->token != COMMA) + && (infoPtr->token != CLOSE_PAREN)) { + goto syntaxError; + } + + if (iPtr->noEval) { + continue; + } + + /* + * At this point we've got two values and an operator. Check + * to make sure that the particular data types are appropriate + * for the particular operator, and perform type conversion + * if necessary. + */ + + switch (operator) { + + /* + * For the operators below, no strings are allowed and + * ints get converted to floats if necessary. + */ + + case MULT: case DIVIDE: case PLUS: case MINUS: + if ((valuePtr->type == TYPE_STRING) + || (value2.type == TYPE_STRING)) { + badType = TYPE_STRING; + goto illegalType; + } + if (valuePtr->type == TYPE_DOUBLE) { + if (value2.type == TYPE_INT) { + value2.doubleValue = value2.intValue; + value2.type = TYPE_DOUBLE; + } + } else if (value2.type == TYPE_DOUBLE) { + if (valuePtr->type == TYPE_INT) { + valuePtr->doubleValue = valuePtr->intValue; + valuePtr->type = TYPE_DOUBLE; + } + } + break; + + /* + * For the operators below, only integers are allowed. + */ + + case MOD: case LEFT_SHIFT: case RIGHT_SHIFT: + case BIT_AND: case BIT_XOR: case BIT_OR: + if (valuePtr->type != TYPE_INT) { + badType = valuePtr->type; + goto illegalType; + } else if (value2.type != TYPE_INT) { + badType = value2.type; + goto illegalType; + } + break; + + /* + * For the operators below, any type is allowed but the + * two operands must have the same type. Convert integers + * to floats and either to strings, if necessary. + */ + + case LESS: case GREATER: case LEQ: case GEQ: + case EQUAL: case NEQ: + if (valuePtr->type == TYPE_STRING) { + if (value2.type != TYPE_STRING) { + ExprMakeString(interp, &value2); + } + } else if (value2.type == TYPE_STRING) { + if (valuePtr->type != TYPE_STRING) { + ExprMakeString(interp, valuePtr); + } + } else if (valuePtr->type == TYPE_DOUBLE) { + if (value2.type == TYPE_INT) { + value2.doubleValue = value2.intValue; + value2.type = TYPE_DOUBLE; + } + } else if (value2.type == TYPE_DOUBLE) { + if (valuePtr->type == TYPE_INT) { + valuePtr->doubleValue = valuePtr->intValue; + valuePtr->type = TYPE_DOUBLE; + } + } + break; + + /* + * For the operators below, no strings are allowed, but + * no int->double conversions are performed. + */ + + case AND: case OR: + if (valuePtr->type == TYPE_STRING) { + badType = valuePtr->type; + goto illegalType; + } + if (value2.type == TYPE_STRING) { + badType = value2.type; + goto illegalType; + } + break; + + /* + * For the operators below, type and conversions are + * irrelevant: they're handled elsewhere. + */ + + case QUESTY: case COLON: + break; + + /* + * Any other operator is an error. + */ + + default: + interp->result = "unknown operator in expression"; + result = TCL_ERROR; + goto done; + } + + /* + * Carry out the function of the specified operator. + */ + + switch (operator) { + case MULT: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue = valuePtr->intValue * value2.intValue; + } else { + valuePtr->doubleValue *= value2.doubleValue; + } + break; + case DIVIDE: + case MOD: + if (valuePtr->type == TYPE_INT) { + long divisor, quot, rem; + int negative; + + if (value2.intValue == 0) { + divideByZero: + interp->result = "divide by zero"; + Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", + interp->result, (char *) NULL); + result = TCL_ERROR; + goto done; + } + + /* + * The code below is tricky because C doesn't guarantee + * much about the properties of the quotient or + * remainder, but Tcl does: the remainder always has + * the same sign as the divisor and a smaller absolute + * value. + */ + + divisor = value2.intValue; + negative = 0; + if (divisor < 0) { + divisor = -divisor; + valuePtr->intValue = -valuePtr->intValue; + negative = 1; + } + quot = valuePtr->intValue / divisor; + rem = valuePtr->intValue % divisor; + if (rem < 0) { + rem += divisor; + quot -= 1; + } + if (negative) { + rem = -rem; + } + valuePtr->intValue = (operator == DIVIDE) ? quot : rem; + } else { + if (value2.doubleValue == 0.0) { + goto divideByZero; + } + valuePtr->doubleValue /= value2.doubleValue; + } + break; + case PLUS: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue = valuePtr->intValue + value2.intValue; + } else { + valuePtr->doubleValue += value2.doubleValue; + } + break; + case MINUS: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue = valuePtr->intValue - value2.intValue; + } else { + valuePtr->doubleValue -= value2.doubleValue; + } + break; + case LEFT_SHIFT: + valuePtr->intValue <<= value2.intValue; + break; + case RIGHT_SHIFT: + /* + * The following code is a bit tricky: it ensures that + * right shifts propagate the sign bit even on machines + * where ">>" won't do it by default. + */ + + if (valuePtr->intValue < 0) { + valuePtr->intValue = + ~((~valuePtr->intValue) >> value2.intValue); + } else { + valuePtr->intValue >>= value2.intValue; + } + break; + case LESS: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue = + valuePtr->intValue < value2.intValue; + } else if (valuePtr->type == TYPE_DOUBLE) { + valuePtr->intValue = + valuePtr->doubleValue < value2.doubleValue; + } else { + valuePtr->intValue = + strcmp(valuePtr->pv.buffer, value2.pv.buffer) < 0; + } + valuePtr->type = TYPE_INT; + break; + case GREATER: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue = + valuePtr->intValue > value2.intValue; + } else if (valuePtr->type == TYPE_DOUBLE) { + valuePtr->intValue = + valuePtr->doubleValue > value2.doubleValue; + } else { + valuePtr->intValue = + strcmp(valuePtr->pv.buffer, value2.pv.buffer) > 0; + } + valuePtr->type = TYPE_INT; + break; + case LEQ: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue = + valuePtr->intValue <= value2.intValue; + } else if (valuePtr->type == TYPE_DOUBLE) { + valuePtr->intValue = + valuePtr->doubleValue <= value2.doubleValue; + } else { + valuePtr->intValue = + strcmp(valuePtr->pv.buffer, value2.pv.buffer) <= 0; + } + valuePtr->type = TYPE_INT; + break; + case GEQ: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue = + valuePtr->intValue >= value2.intValue; + } else if (valuePtr->type == TYPE_DOUBLE) { + valuePtr->intValue = + valuePtr->doubleValue >= value2.doubleValue; + } else { + valuePtr->intValue = + strcmp(valuePtr->pv.buffer, value2.pv.buffer) >= 0; + } + valuePtr->type = TYPE_INT; + break; + case EQUAL: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue = + valuePtr->intValue == value2.intValue; + } else if (valuePtr->type == TYPE_DOUBLE) { + valuePtr->intValue = + valuePtr->doubleValue == value2.doubleValue; + } else { + valuePtr->intValue = + strcmp(valuePtr->pv.buffer, value2.pv.buffer) == 0; + } + valuePtr->type = TYPE_INT; + break; + case NEQ: + if (valuePtr->type == TYPE_INT) { + valuePtr->intValue = + valuePtr->intValue != value2.intValue; + } else if (valuePtr->type == TYPE_DOUBLE) { + valuePtr->intValue = + valuePtr->doubleValue != value2.doubleValue; + } else { + valuePtr->intValue = + strcmp(valuePtr->pv.buffer, value2.pv.buffer) != 0; + } + valuePtr->type = TYPE_INT; + break; + case BIT_AND: + valuePtr->intValue &= value2.intValue; + break; + case BIT_XOR: + valuePtr->intValue ^= value2.intValue; + break; + case BIT_OR: + valuePtr->intValue |= value2.intValue; + break; + + /* + * For AND and OR, we know that the first value has already + * been converted to an integer. Thus we need only consider + * the possibility of int vs. double for the second value. + */ + + case AND: + if (value2.type == TYPE_DOUBLE) { + value2.intValue = value2.doubleValue != 0; + value2.type = TYPE_INT; + } + valuePtr->intValue = valuePtr->intValue && value2.intValue; + break; + case OR: + if (value2.type == TYPE_DOUBLE) { + value2.intValue = value2.doubleValue != 0; + value2.type = TYPE_INT; + } + valuePtr->intValue = valuePtr->intValue || value2.intValue; + break; + + case COLON: + interp->result = "can't have : operator without ? first"; + result = TCL_ERROR; + goto done; + } + } + + done: + if (value2.pv.buffer != value2.staticSpace) { + ckfree(value2.pv.buffer); + } + return result; + + syntaxError: + Tcl_AppendResult(interp, "syntax error in expression \"", + infoPtr->originalExpr, "\"", (char *) NULL); + result = TCL_ERROR; + goto done; + + illegalType: + Tcl_AppendResult(interp, "can't use ", (badType == TYPE_DOUBLE) ? + "floating-point value" : "non-numeric string", + " as operand of \"", operatorStrings[operator], "\"", + (char *) NULL); + result = TCL_ERROR; + goto done; +} + +/* + *-------------------------------------------------------------- + * + * ExprMakeString -- + * + * Convert a value from int or double representation to + * a string. + * + * Results: + * The information at *valuePtr gets converted to string + * format, if it wasn't that way already. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static void +ExprMakeString(interp, valuePtr) + Tcl_Interp *interp; /* Interpreter to use for precision + * information. */ + register Value *valuePtr; /* Value to be converted. */ +{ + int shortfall; + + shortfall = 150 - (valuePtr->pv.end - valuePtr->pv.buffer); + if (shortfall > 0) { + (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall); + } + if (valuePtr->type == TYPE_INT) { + sprintf(valuePtr->pv.buffer, "%ld", valuePtr->intValue); + } else if (valuePtr->type == TYPE_DOUBLE) { + Tcl_PrintDouble(interp, valuePtr->doubleValue, valuePtr->pv.buffer); + } + valuePtr->type = TYPE_STRING; +} + +/* + *-------------------------------------------------------------- + * + * ExprTopLevel -- + * + * This procedure provides top-level functionality shared by + * procedures like Tcl_ExprInt, Tcl_ExprDouble, etc. + * + * Results: + * The result is a standard Tcl return value. If an error + * occurs then an error message is left in interp->result. + * The value of the expression is returned in *valuePtr, in + * whatever form it ends up in (could be string or integer + * or double). Caller may need to convert result. Caller + * is also responsible for freeing string memory in *valuePtr, + * if any was allocated. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +ExprTopLevel(interp, string, valuePtr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + char *string; /* Expression to evaluate. */ + Value *valuePtr; /* Where to store result. Should + * not be initialized by caller. */ +{ + ExprInfo info; + int result; + + /* + * Create the math functions the first time an expression is + * evaluated. + */ + + if (!(((Interp *) interp)->flags & EXPR_INITIALIZED)) { + BuiltinFunc *funcPtr; + + ((Interp *) interp)->flags |= EXPR_INITIALIZED; + for (funcPtr = funcTable; funcPtr->name != NULL; + funcPtr++) { + Tcl_CreateMathFunc(interp, funcPtr->name, funcPtr->numArgs, + funcPtr->argTypes, funcPtr->proc, funcPtr->clientData); + } + } + + info.originalExpr = string; + info.expr = string; + valuePtr->pv.buffer = valuePtr->pv.next = valuePtr->staticSpace; + valuePtr->pv.end = valuePtr->pv.buffer + STATIC_STRING_SPACE - 1; + valuePtr->pv.expandProc = TclExpandParseValue; + valuePtr->pv.clientData = (ClientData) NULL; + + result = ExprGetValue(interp, &info, -1, valuePtr); + if (result != TCL_OK) { + return result; + } + if (info.token != END) { + Tcl_AppendResult(interp, "syntax error in expression \"", + string, "\"", (char *) NULL); + return TCL_ERROR; + } + if ((valuePtr->type == TYPE_DOUBLE) && (IS_NAN(valuePtr->doubleValue) + || IS_INF(valuePtr->doubleValue))) { + /* + * IEEE floating-point error. + */ + + TclExprFloatError(interp, valuePtr->doubleValue); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean -- + * + * Procedures to evaluate an expression and return its value + * in a particular form. + * + * Results: + * Each of the procedures below returns a standard Tcl result. + * If an error occurs then an error message is left in + * interp->result. Otherwise the value of the expression, + * in the appropriate form, is stored at *resultPtr. If + * the expression had a result that was incompatible with the + * desired form then an error is returned. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tcl_ExprLong(interp, string, ptr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + char *string; /* Expression to evaluate. */ + long *ptr; /* Where to store result. */ +{ + Value value; + int result; + + result = ExprTopLevel(interp, string, &value); + if (result == TCL_OK) { + if (value.type == TYPE_INT) { + *ptr = value.intValue; + } else if (value.type == TYPE_DOUBLE) { + *ptr = (long) value.doubleValue; + } else { + interp->result = "expression didn't have numeric value"; + result = TCL_ERROR; + } + } + if (value.pv.buffer != value.staticSpace) { + ckfree(value.pv.buffer); + } + return result; +} + +int +Tcl_ExprDouble(interp, string, ptr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + char *string; /* Expression to evaluate. */ + double *ptr; /* Where to store result. */ +{ + Value value; + int result; + + result = ExprTopLevel(interp, string, &value); + if (result == TCL_OK) { + if (value.type == TYPE_INT) { + *ptr = value.intValue; + } else if (value.type == TYPE_DOUBLE) { + *ptr = value.doubleValue; + } else { + interp->result = "expression didn't have numeric value"; + result = TCL_ERROR; + } + } + if (value.pv.buffer != value.staticSpace) { + ckfree(value.pv.buffer); + } + return result; +} + +int +Tcl_ExprBoolean(interp, string, ptr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + char *string; /* Expression to evaluate. */ + int *ptr; /* Where to store 0/1 result. */ +{ + Value value; + int result; + + result = ExprTopLevel(interp, string, &value); + if (result == TCL_OK) { + if (value.type == TYPE_INT) { + *ptr = value.intValue != 0; + } else if (value.type == TYPE_DOUBLE) { + *ptr = value.doubleValue != 0.0; + } else { + result = Tcl_GetBoolean(interp, value.pv.buffer, ptr); + } + } + if (value.pv.buffer != value.staticSpace) { + ckfree(value.pv.buffer); + } + return result; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_ExprString -- + * + * Evaluate an expression and return its value in string form. + * + * Results: + * A standard Tcl result. If the result is TCL_OK, then the + * interpreter's result is set to the string value of the + * expression. If the result is TCL_OK, then interp->result + * contains an error message. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tcl_ExprString(interp, string) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + char *string; /* Expression to evaluate. */ +{ + Value value; + int result; + + result = ExprTopLevel(interp, string, &value); + if (result == TCL_OK) { + if (value.type == TYPE_INT) { + sprintf(interp->result, "%ld", value.intValue); + } else if (value.type == TYPE_DOUBLE) { + Tcl_PrintDouble(interp, value.doubleValue, interp->result); + } else { + if (value.pv.buffer != value.staticSpace) { + interp->result = value.pv.buffer; + interp->freeProc = TCL_DYNAMIC; + value.pv.buffer = value.staticSpace; + } else { + Tcl_SetResult(interp, value.pv.buffer, TCL_VOLATILE); + } + } + } + if (value.pv.buffer != value.staticSpace) { + ckfree(value.pv.buffer); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateMathFunc -- + * + * Creates a new math function for expressions in a given + * interpreter. + * + * Results: + * None. + * + * Side effects: + * The function defined by "name" is created; if such a function + * already existed then its definition is overriden. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) + Tcl_Interp *interp; /* Interpreter in which function is + * to be available. */ + char *name; /* Name of function (e.g. "sin"). */ + int numArgs; /* Nnumber of arguments required by + * function. */ + Tcl_ValueType *argTypes; /* Array of types acceptable for + * each argument. */ + Tcl_MathProc *proc; /* Procedure that implements the + * math function. */ + ClientData clientData; /* Additional value to pass to the + * function. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + MathFunc *mathFuncPtr; + int new, i; + + hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new); + if (new) { + Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc))); + } + mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); + if (numArgs > MAX_MATH_ARGS) { + numArgs = MAX_MATH_ARGS; + } + mathFuncPtr->numArgs = numArgs; + for (i = 0; i < numArgs; i++) { + mathFuncPtr->argTypes[i] = argTypes[i]; + } + mathFuncPtr->proc = proc; + mathFuncPtr->clientData = clientData; +} + +/* + *---------------------------------------------------------------------- + * + * ExprMathFunc -- + * + * This procedure is invoked to parse a math function from an + * expression string, carry out the function, and return the + * value computed. + * + * Results: + * TCL_OK is returned if all went well and the function's value + * was computed successfully. If an error occurred, TCL_ERROR + * is returned and an error message is left in interp->result. + * After a successful return infoPtr has been updated to refer + * to the character just after the function call, the token is + * set to VALUE, and the value is stored in valuePtr. + * + * Side effects: + * Embedded commands could have arbitrary side-effects. + * + *---------------------------------------------------------------------- + */ + +static int +ExprMathFunc(interp, infoPtr, valuePtr) + Tcl_Interp *interp; /* Interpreter to use for error + * reporting. */ + register ExprInfo *infoPtr; /* Describes the state of the parse. + * infoPtr->expr must point to the + * first character of the function's + * name. */ + register Value *valuePtr; /* Where to store value, if that is + * what's parsed from string. Caller + * must have initialized pv field + * correctly. */ +{ + Interp *iPtr = (Interp *) interp; + MathFunc *mathFuncPtr; /* Info about math function. */ + Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */ + Tcl_Value funcResult; /* Result of function call. */ + Tcl_HashEntry *hPtr; + char *p, *funcName, savedChar; + int i, result; + + /* + * Find the end of the math function's name and lookup the MathFunc + * record for the function. + */ + + p = funcName = infoPtr->expr; + while (isalnum(UCHAR(*p)) || (*p == '_')) { + p++; + } + infoPtr->expr = p; + result = ExprLex(interp, infoPtr, valuePtr); + if (result != TCL_OK) { + return TCL_ERROR; + } + if (infoPtr->token != OPEN_PAREN) { + goto syntaxError; + } + savedChar = *p; + *p = 0; + hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "unknown math function \"", funcName, + "\"", (char *) NULL); + *p = savedChar; + return TCL_ERROR; + } + *p = savedChar; + mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); + + /* + * Scan off the arguments for the function, if there are any. + */ + + if (mathFuncPtr->numArgs == 0) { + result = ExprLex(interp, infoPtr, valuePtr); + if ((result != TCL_OK) || (infoPtr->token != CLOSE_PAREN)) { + goto syntaxError; + } + } else { + for (i = 0; ; i++) { + valuePtr->pv.next = valuePtr->pv.buffer; + result = ExprGetValue(interp, infoPtr, -1, valuePtr); + if (result != TCL_OK) { + return result; + } + if (valuePtr->type == TYPE_STRING) { + interp->result = + "argument to math function didn't have numeric value"; + return TCL_ERROR; + } + + /* + * Copy the value to the argument record, converting it if + * necessary. + */ + + if (valuePtr->type == TYPE_INT) { + if (mathFuncPtr->argTypes[i] == TCL_DOUBLE) { + args[i].type = TCL_DOUBLE; + args[i].doubleValue = valuePtr->intValue; + } else { + args[i].type = TCL_INT; + args[i].intValue = valuePtr->intValue; + } + } else { + if (mathFuncPtr->argTypes[i] == TCL_INT) { + args[i].type = TCL_INT; + args[i].intValue = (long) valuePtr->doubleValue; + } else { + args[i].type = TCL_DOUBLE; + args[i].doubleValue = valuePtr->doubleValue; + } + } + + /* + * Check for a comma separator between arguments or a close-paren + * to end the argument list. + */ + + if (i == (mathFuncPtr->numArgs-1)) { + if (infoPtr->token == CLOSE_PAREN) { + break; + } + if (infoPtr->token == COMMA) { + interp->result = "too many arguments for math function"; + return TCL_ERROR; + } else { + goto syntaxError; + } + } + if (infoPtr->token != COMMA) { + if (infoPtr->token == CLOSE_PAREN) { + interp->result = "too few arguments for math function"; + return TCL_ERROR; + } else { + goto syntaxError; + } + } + } + } + if (iPtr->noEval) { + valuePtr->type = TYPE_INT; + valuePtr->intValue = 0; + infoPtr->token = VALUE; + return TCL_OK; + } + + /* + * Invoke the function and copy its result back into valuePtr. + */ + + tcl_MathInProgress++; + result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args, + &funcResult); + tcl_MathInProgress--; + if (result != TCL_OK) { + return result; + } + if (funcResult.type == TCL_INT) { + valuePtr->type = TYPE_INT; + valuePtr->intValue = funcResult.intValue; + } else { + valuePtr->type = TYPE_DOUBLE; + valuePtr->doubleValue = funcResult.doubleValue; + } + infoPtr->token = VALUE; + return TCL_OK; + + syntaxError: + Tcl_AppendResult(interp, "syntax error in expression \"", + infoPtr->originalExpr, "\"", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TclExprFloatError -- + * + * This procedure is called when an error occurs during a + * floating-point operation. It reads errno and sets + * interp->result accordingly. + * + * Results: + * Interp->result is set to hold an error message. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclExprFloatError(interp, value) + Tcl_Interp *interp; /* Where to store error message. */ + double value; /* Value returned after error; used to + * distinguish underflows from overflows. */ +{ + char buf[20]; + + if ((errno == EDOM) || (value != value)) { + interp->result = "domain error: argument not in valid range"; + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", interp->result, + (char *) NULL); + } else if ((errno == ERANGE) || IS_INF(value)) { + if (value == 0.0) { + interp->result = "floating-point value too small to represent"; + Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", interp->result, + (char *) NULL); + } else { + interp->result = "floating-point value too large to represent"; + Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", interp->result, + (char *) NULL); + } + } else { + sprintf(buf, "%d", errno); + Tcl_AppendResult(interp, "unknown floating-point error, ", + "errno = ", buf, (char *) NULL); + Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", interp->result, + (char *) NULL); + } +} + +/* + *---------------------------------------------------------------------- + * + * Math Functions -- + * + * This page contains the procedures that implement all of the + * built-in math functions for expressions. + * + * Results: + * Each procedure returns TCL_OK if it succeeds and places result + * information at *resultPtr. If it fails it returns TCL_ERROR + * and leaves an error message in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ExprUnaryFunc(clientData, interp, args, resultPtr) + ClientData clientData; /* Contains address of procedure that + * takes one double argument and + * returns a double result. */ + Tcl_Interp *interp; + Tcl_Value *args; + Tcl_Value *resultPtr; +{ + double (*func) _ANSI_ARGS_((double)) = (double (*)_ANSI_ARGS_((double))) clientData; + + errno = 0; + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = (*func)(args[0].doubleValue); + if (errno != 0) { + TclExprFloatError(interp, resultPtr->doubleValue); + return TCL_ERROR; + } + return TCL_OK; +} + +static int +ExprBinaryFunc(clientData, interp, args, resultPtr) + ClientData clientData; /* Contains address of procedure that + * takes two double arguments and + * returns a double result. */ + Tcl_Interp *interp; + Tcl_Value *args; + Tcl_Value *resultPtr; +{ + double (*func) _ANSI_ARGS_((double, double)) + = (double (*)_ANSI_ARGS_((double, double))) clientData; + + errno = 0; + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = (*func)(args[0].doubleValue, args[1].doubleValue); + if (errno != 0) { + TclExprFloatError(interp, resultPtr->doubleValue); + return TCL_ERROR; + } + return TCL_OK; +} + + /* ARGSUSED */ +static int +ExprAbsFunc(clientData, interp, args, resultPtr) + ClientData clientData; + Tcl_Interp *interp; + Tcl_Value *args; + Tcl_Value *resultPtr; +{ + resultPtr->type = TCL_DOUBLE; + if (args[0].type == TCL_DOUBLE) { + resultPtr->type = TCL_DOUBLE; + if (args[0].doubleValue < 0) { + resultPtr->doubleValue = -args[0].doubleValue; + } else { + resultPtr->doubleValue = args[0].doubleValue; + } + } else { + resultPtr->type = TCL_INT; + if (args[0].intValue < 0) { + resultPtr->intValue = -args[0].intValue; + if (resultPtr->intValue < 0) { + interp->result = "integer value too large to represent"; + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", interp->result, + (char *) NULL); + return TCL_ERROR; + } + } else { + resultPtr->intValue = args[0].intValue; + } + } + return TCL_OK; +} + + /* ARGSUSED */ +static int +ExprDoubleFunc(clientData, interp, args, resultPtr) + ClientData clientData; + Tcl_Interp *interp; + Tcl_Value *args; + Tcl_Value *resultPtr; +{ + resultPtr->type = TCL_DOUBLE; + if (args[0].type == TCL_DOUBLE) { + resultPtr->doubleValue = args[0].doubleValue; + } else { + resultPtr->doubleValue = args[0].intValue; + } + return TCL_OK; +} + + /* ARGSUSED */ +static int +ExprIntFunc(clientData, interp, args, resultPtr) + ClientData clientData; + Tcl_Interp *interp; + Tcl_Value *args; + Tcl_Value *resultPtr; +{ + resultPtr->type = TCL_INT; + if (args[0].type == TCL_INT) { + resultPtr->intValue = args[0].intValue; + } else { + if (args[0].doubleValue < 0) { + if (args[0].doubleValue < (double) (long) LONG_MIN) { + tooLarge: + interp->result = "integer value too large to represent"; + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + interp->result, (char *) NULL); + return TCL_ERROR; + } + } else { + if (args[0].doubleValue > (double) LONG_MAX) { + goto tooLarge; + } + } + resultPtr->intValue = (long) args[0].doubleValue; + } + return TCL_OK; +} + + /* ARGSUSED */ +static int +ExprRoundFunc(clientData, interp, args, resultPtr) + ClientData clientData; + Tcl_Interp *interp; + Tcl_Value *args; + Tcl_Value *resultPtr; +{ + resultPtr->type = TCL_INT; + if (args[0].type == TCL_INT) { + resultPtr->intValue = args[0].intValue; + } else { + if (args[0].doubleValue < 0) { + if (args[0].doubleValue <= (((double) (long) LONG_MIN) - 0.5)) { + tooLarge: + interp->result = "integer value too large to represent"; + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + interp->result, (char *) NULL); + return TCL_ERROR; + } + resultPtr->intValue = (long) (args[0].doubleValue - 0.5); + } else { + if (args[0].doubleValue >= (((double) LONG_MAX + 0.5))) { + goto tooLarge; + } + resultPtr->intValue = (long) (args[0].doubleValue + 0.5); + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ExprLooksLikeInt -- + * + * This procedure decides whether the leading characters of a + * string look like an integer or something else (such as a + * floating-point number or string). + * + * Results: + * The return value is 1 if the leading characters of p look + * like a valid Tcl integer. If they look like a floating-point + * number (e.g. "e01" or "2.4"), or if they don't look like a + * number at all, then 0 is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ExprLooksLikeInt(p) + char *p; /* Pointer to string. */ +{ + while (isspace(UCHAR(*p))) { + p++; + } + if ((*p == '+') || (*p == '-')) { + p++; + } + if (!isdigit(UCHAR(*p))) { + return 0; + } + p++; + while (isdigit(UCHAR(*p))) { + p++; + } + if ((*p != '.') && (*p != 'e') && (*p != 'E')) { + return 1; + } + return 0; +} |
