archie/tcl7.6/generic/tclExpr.c
2024-05-27 16:40:40 +02:00

2062 lines
54 KiB
C
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

/*
* 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.92 96/09/06 13:22: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 actual
* 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 (result != TCL_OK) {
goto done;
}
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);
if (result != TCL_OK) {
goto done;
}
}
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;
}