/* * 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 #endif #ifndef TCL_NO_MATH #include #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; }