diff options
Diffstat (limited to 'contrib/tcl/generic/tclExpr.c')
| -rw-r--r-- | contrib/tcl/generic/tclExpr.c | 2055 |
1 files changed, 0 insertions, 2055 deletions
diff --git a/contrib/tcl/generic/tclExpr.c b/contrib/tcl/generic/tclExpr.c deleted file mode 100644 index 13d020fa49c2f..0000000000000 --- a/contrib/tcl/generic/tclExpr.c +++ /dev/null @@ -1,2055 +0,0 @@ -/* - * 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; -} |