Newsgroups: comp.sources.misc From: karl@sugar.neosoft.com (Karl Lehenbauer) Subject: v25i094: tcl - tool command language, version 6.1, Part26/33 Message-ID: <1991Nov15.225535.21698@sparky.imd.sterling.com> X-Md4-Signature: 2751a496be310cba7ed012820f0ea459 Date: Fri, 15 Nov 1991 22:55:35 GMT Approved: kent@sparky.imd.sterling.com Submitted-by: karl@sugar.neosoft.com (Karl Lehenbauer) Posting-number: Volume 25, Issue 94 Archive-name: tcl/part26 Environment: UNIX #! /bin/sh # This is a shell archive. Remove anything before this line, then unpack # it by saving it into a file and typing "sh file". To overwrite existing # files, type "sh file -c". You can also feed this as standard input via # unshar, or by typing "sh 'tcl6.1/tclExpr.c' <<'END_OF_FILE' X/* X * tclExpr.c -- X * X * This file contains the code to evaluate expressions for X * Tcl. X * X * This implementation of floating-point support was modelled X * after an initial implementation by Bill Carpenter. X * X * Copyright 1987-1991 Regents of the University of California X * Permission to use, copy, modify, and distribute this X * software and its documentation for any purpose and without X * fee is hereby granted, provided that the above copyright X * notice appear in all copies. The University of California X * makes no representations about the suitability of this X * software for any purpose. It is provided "as is" without X * express or implied warranty. X */ X X#ifndef lint Xstatic char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclExpr.c,v 1.32 91/10/31 14:04:03 ouster Exp $ SPRITE (Berkeley)"; X#endif X X#include "tclInt.h" X Xdouble strtod(); X X/* X * The stuff below is a bit of a hack so that this file can be used X * in environments that include no UNIX, i.e. no errno. Just define X * errno here. X */ X X#ifndef TCL_NO_UNIX X#include "tclUnix.h" X#else Xint errno; X#define ERANGE 34 X#endif X X/* X * The data structure below is used to describe an expression value, X * which can be either an integer (the usual case), a double-precision X * floating-point value, or a string. A given number has only one X * value at a time. X */ X X#define STATIC_STRING_SPACE 150 X Xtypedef struct { X long intValue; /* Integer value, if any. */ X double doubleValue; /* Floating-point value, if any. */ X ParseValue pv; /* Used to hold a string value, if any. */ X char staticSpace[STATIC_STRING_SPACE]; X /* Storage for small strings; large ones X * are malloc-ed. */ X int type; /* Type of value: TYPE_INT, TYPE_DOUBLE, X * or TYPE_STRING. */ X} Value; X X/* X * Valid values for type: X */ X X#define TYPE_INT 0 X#define TYPE_DOUBLE 1 X#define TYPE_STRING 2 X X X/* X * The data structure below describes the state of parsing an expression. X * It's passed among the routines in this module. X */ X Xtypedef struct { X char *originalExpr; /* The entire expression, as originally X * passed to Tcl_Expr. */ X char *expr; /* Position to the next character to be X * scanned from the expression string. */ X int token; /* Type of the last token to be parsed from X * expr. See below for definitions. X * Corresponds to the characters just X * before expr. */ X} ExprInfo; X X/* X * The token types are defined below. In addition, there is a table X * associating a precedence with each operator. The order of types X * is important. Consult the code before changing it. X */ X X#define VALUE 0 X#define OPEN_PAREN 1 X#define CLOSE_PAREN 2 X#define END 3 X#define UNKNOWN 4 X X/* X * Binary operators: X */ X X#define MULT 8 X#define DIVIDE 9 X#define MOD 10 X#define PLUS 11 X#define MINUS 12 X#define LEFT_SHIFT 13 X#define RIGHT_SHIFT 14 X#define LESS 15 X#define GREATER 16 X#define LEQ 17 X#define GEQ 18 X#define EQUAL 19 X#define NEQ 20 X#define BIT_AND 21 X#define BIT_XOR 22 X#define BIT_OR 23 X#define AND 24 X#define OR 25 X#define QUESTY 26 X#define COLON 27 X X/* X * Unary operators: X */ X X#define UNARY_MINUS 28 X#define NOT 29 X#define BIT_NOT 30 X X/* X * Precedence table. The values for non-operator token types are ignored. X */ X Xint precTable[] = { X 0, 0, 0, 0, 0, 0, 0, 0, X 11, 11, 11, /* MULT, DIVIDE, MOD */ X 10, 10, /* PLUS, MINUS */ X 9, 9, /* LEFT_SHIFT, RIGHT_SHIFT */ X 8, 8, 8, 8, /* LESS, GREATER, LEQ, GEQ */ X 7, 7, /* EQUAL, NEQ */ X 6, /* BIT_AND */ X 5, /* BIT_XOR */ X 4, /* BIT_OR */ X 3, /* AND */ X 2, /* OR */ X 1, 1, /* QUESTY, COLON */ X 12, 12, 12 /* UNARY_MINUS, NOT, BIT_NOT */ X}; X X/* X * Mapping from operator numbers to strings; used for error messages. X */ X Xchar *operatorStrings[] = { X "VALUE", "(", ")", "END", "UNKNOWN", "5", "6", "7", X "*", "/", "%", "+", "-", "<<", ">>", "<", ">", "<=", X ">=", "==", "!=", "&", "^", "|", "&&", "||", "?", ":", X "-", "!", "~" X}; X X/* X * Declarations for local procedures to this file: X */ X Xstatic int ExprGetValue _ANSI_ARGS_((Tcl_Interp *interp, X ExprInfo *infoPtr, int prec, Value *valuePtr)); Xstatic int ExprLex _ANSI_ARGS_((Tcl_Interp *interp, X ExprInfo *infoPtr, Value *valuePtr)); Xstatic void ExprMakeString _ANSI_ARGS_((Value *valuePtr)); Xstatic int ExprParseString _ANSI_ARGS_((Tcl_Interp *interp, X char *string, Value *valuePtr)); Xstatic int ExprTopLevel _ANSI_ARGS_((Tcl_Interp *interp, X char *string, Value *valuePtr)); X X/* X *-------------------------------------------------------------- X * X * ExprParseString -- X * X * Given a string (such as one coming from command or variable X * substitution), make a Value based on the string. The value X * will be a floating-point or integer, if possible, or else it X * will just be a copy of the string. X * X * Results: X * TCL_OK is returned under normal circumstances, and TCL_ERROR X * is returned if a floating-point overflow or underflow occurred X * while reading in a number. The value at *valuePtr is modified X * to hold a number, if possible. X * X * Side effects: X * None. X * X *-------------------------------------------------------------- X */ X Xstatic int XExprParseString(interp, string, valuePtr) X Tcl_Interp *interp; /* Where to store error message. */ X char *string; /* String to turn into value. */ X Value *valuePtr; /* Where to store value information. X * Caller must have initialized pv field. */ X{ X register char c; X X /* X * Try to convert the string to a number. X */ X X c = *string; X if (((c >= '0') && (c <= '9')) || (c == '-')) { X char *term; X X valuePtr->type = TYPE_INT; X errno = 0; X valuePtr->intValue = strtol(string, &term, 0); X c = *term; X if ((c == '\0') && (errno != ERANGE)) { X return TCL_OK; X } X if ((c == '.') || (c == 'e') || (c == 'E') || (errno == ERANGE)) { X errno = 0; X valuePtr->doubleValue = strtod(string, &term); X if (errno == ERANGE) { X Tcl_ResetResult(interp); X if (valuePtr->doubleValue == 0.0) { X Tcl_AppendResult(interp, "floating-point value \"", X string, "\" too small to represent", X (char *) NULL); X } else { X Tcl_AppendResult(interp, "floating-point value \"", X string, "\" too large to represent", X (char *) NULL); X } X return TCL_ERROR; X } X if (*term == '\0') { X valuePtr->type = TYPE_DOUBLE; X return TCL_OK; X } X } X } X X /* X * Not a valid number. Save a string value (but don't do anything X * if it's already the value). X */ X X valuePtr->type = TYPE_STRING; X if (string != valuePtr->pv.buffer) { X int length, shortfall; X X length = strlen(string); X valuePtr->pv.next = valuePtr->pv.buffer; X shortfall = length - (valuePtr->pv.end - valuePtr->pv.buffer); X if (shortfall > 0) { X (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall); X } X strcpy(valuePtr->pv.buffer, string); X } X return TCL_OK; X} X X/* X *---------------------------------------------------------------------- X * X * ExprLex -- X * X * Lexical analyzer for expression parser: parses a single value, X * operator, or other syntactic element from an expression string. X * X * Results: X * TCL_OK is returned unless an error occurred while doing lexical X * analysis or executing an embedded command. In that case a X * standard Tcl error is returned, using interp->result to hold X * an error message. In the event of a successful return, the token X * and field in infoPtr is updated to refer to the next symbol in X * the expression string, and the expr field is advanced past that X * token; if the token is a value, then the value is stored at X * valuePtr. X * X * Side effects: X * None. X * X *---------------------------------------------------------------------- X */ X Xstatic int XExprLex(interp, infoPtr, valuePtr) X Tcl_Interp *interp; /* Interpreter to use for error X * reporting. */ X register ExprInfo *infoPtr; /* Describes the state of the parse. */ X register Value *valuePtr; /* Where to store value, if that is X * what's parsed from string. Caller X * must have initialized pv field X * correctly. */ X{ X register char *p, c; X char *var, *term; X int result; X X p = infoPtr->expr; X c = *p; X while (isspace(c)) { X p++; X c = *p; X } X infoPtr->expr = p+1; X switch (c) { X case '0': X case '1': X case '2': X case '3': X case '4': X case '5': X case '6': X case '7': X case '8': X case '9': X case '.': X X /* X * Number. First read an integer. Then if it looks like X * there's a floating-point number (or if it's too big a X * number to fit in an integer), parse it as a floating-point X * number. X */ X X infoPtr->token = VALUE; X valuePtr->type = TYPE_INT; X errno = 0; X valuePtr->intValue = strtoul(p, &term, 0); X c = *term; X if ((c == '.') || (c == 'e') || (c == 'E') || (errno == ERANGE)) { X char *term2; X X errno = 0; X valuePtr->doubleValue = strtod(p, &term2); X if (errno == ERANGE) { X Tcl_ResetResult(interp); X if (valuePtr->doubleValue == 0.0) { X interp->result = X "floating-point value too small to represent"; X } else { X interp->result = X "floating-point value too large to represent"; X } X return TCL_ERROR; X } X if (term2 == infoPtr->expr) { X interp->result = "poorly-formed floating-point value"; X return TCL_ERROR; X } X valuePtr->type = TYPE_DOUBLE; X infoPtr->expr = term2; X } else { X infoPtr->expr = term; X } X return TCL_OK; X X case '$': X X /* X * Variable. Fetch its value, then see if it makes sense X * as an integer or floating-point number. X */ X X infoPtr->token = VALUE; X var = Tcl_ParseVar(interp, p, &infoPtr->expr); X if (var == NULL) { X return TCL_ERROR; X } X if (((Interp *) interp)->noEval) { X valuePtr->type = TYPE_INT; X valuePtr->intValue = 0; X return TCL_OK; X } X return ExprParseString(interp, var, valuePtr); X X case '[': X infoPtr->token = VALUE; X result = Tcl_Eval(interp, p+1, TCL_BRACKET_TERM, X &infoPtr->expr); X if (result != TCL_OK) { X return result; X } X infoPtr->expr++; X if (((Interp *) interp)->noEval) { X valuePtr->type = TYPE_INT; X valuePtr->intValue = 0; X Tcl_ResetResult(interp); X return TCL_OK; X } X result = ExprParseString(interp, interp->result, valuePtr); X if (result != TCL_OK) { X return result; X } X Tcl_ResetResult(interp); X return TCL_OK; X X case '"': X infoPtr->token = VALUE; X result = TclParseQuotes(interp, infoPtr->expr, '"', 0, X &infoPtr->expr, &valuePtr->pv); X if (result != TCL_OK) { X return result; X } X return ExprParseString(interp, valuePtr->pv.buffer, valuePtr); X X case '{': X infoPtr->token = VALUE; X result = TclParseBraces(interp, infoPtr->expr, &infoPtr->expr, X &valuePtr->pv); X if (result != TCL_OK) { X return result; X } X return ExprParseString(interp, valuePtr->pv.buffer, valuePtr); X X case '(': X infoPtr->token = OPEN_PAREN; X return TCL_OK; X X case ')': X infoPtr->token = CLOSE_PAREN; X return TCL_OK; X X case '*': X infoPtr->token = MULT; X return TCL_OK; X X case '/': X infoPtr->token = DIVIDE; X return TCL_OK; X X case '%': X infoPtr->token = MOD; X return TCL_OK; X X case '+': X infoPtr->token = PLUS; X return TCL_OK; X X case '-': X infoPtr->token = MINUS; X return TCL_OK; X X case '?': X infoPtr->token = QUESTY; X return TCL_OK; X X case ':': X infoPtr->token = COLON; X return TCL_OK; X X case '<': X switch (p[1]) { X case '<': X infoPtr->expr = p+2; X infoPtr->token = LEFT_SHIFT; X break; X case '=': X infoPtr->expr = p+2; X infoPtr->token = LEQ; X break; X default: X infoPtr->token = LESS; X break; X } X return TCL_OK; X X case '>': X switch (p[1]) { X case '>': X infoPtr->expr = p+2; X infoPtr->token = RIGHT_SHIFT; X break; X case '=': X infoPtr->expr = p+2; X infoPtr->token = GEQ; X break; X default: X infoPtr->token = GREATER; X break; X } X return TCL_OK; X X case '=': X if (p[1] == '=') { X infoPtr->expr = p+2; X infoPtr->token = EQUAL; X } else { X infoPtr->token = UNKNOWN; X } X return TCL_OK; X X case '!': X if (p[1] == '=') { X infoPtr->expr = p+2; X infoPtr->token = NEQ; X } else { X infoPtr->token = NOT; X } X return TCL_OK; X X case '&': X if (p[1] == '&') { X infoPtr->expr = p+2; X infoPtr->token = AND; X } else { X infoPtr->token = BIT_AND; X } X return TCL_OK; X X case '^': X infoPtr->token = BIT_XOR; X return TCL_OK; X X case '|': X if (p[1] == '|') { X infoPtr->expr = p+2; X infoPtr->token = OR; X } else { X infoPtr->token = BIT_OR; X } X return TCL_OK; X X case '~': X infoPtr->token = BIT_NOT; X return TCL_OK; X X case 0: X infoPtr->token = END; X infoPtr->expr = p; X return TCL_OK; X X default: X infoPtr->expr = p+1; X infoPtr->token = UNKNOWN; X return TCL_OK; X } X} X X/* X *---------------------------------------------------------------------- X * X * ExprGetValue -- X * X * Parse a "value" from the remainder of the expression in infoPtr. X * X * Results: X * Normally TCL_OK is returned. The value of the expression is X * returned in *valuePtr. If an error occurred, then interp->result X * contains an error message and TCL_ERROR is returned. X * InfoPtr->token will be left pointing to the token AFTER the X * expression, and infoPtr->expr will point to the character just X * after the terminating token. X * X * Side effects: X * None. X * X *---------------------------------------------------------------------- X */ X Xstatic int XExprGetValue(interp, infoPtr, prec, valuePtr) X Tcl_Interp *interp; /* Interpreter to use for error X * reporting. */ X register ExprInfo *infoPtr; /* Describes the state of the parse X * just before the value (i.e. ExprLex X * will be called to get first token X * of value). */ X int prec; /* Treat any un-parenthesized operator X * with precedence <= this as the end X * of the expression. */ X Value *valuePtr; /* Where to store the value of the X * expression. Caller must have X * initialized pv field. */ X{ X Interp *iPtr = (Interp *) interp; X Value value2; /* Second operand for current X * operator. */ X int operator; /* Current operator (either unary X * or binary). */ X int badType; /* Type of offending argument; used X * for error messages. */ X int gotOp; /* Non-zero means already lexed the X * operator (while picking up value X * for unary operator). Don't lex X * again. */ X int result; X X /* X * There are two phases to this procedure. First, pick off an initial X * value. Then, parse (binary operator, value) pairs until done. X */ X X gotOp = 0; X value2.pv.buffer = value2.pv.next = value2.staticSpace; X value2.pv.end = value2.pv.buffer + STATIC_STRING_SPACE - 1; X value2.pv.expandProc = TclExpandParseValue; X value2.pv.clientData = (ClientData) NULL; X result = ExprLex(interp, infoPtr, valuePtr); X if (result != TCL_OK) { X goto done; X } X if (infoPtr->token == OPEN_PAREN) { X X /* X * Parenthesized sub-expression. X */ X X result = ExprGetValue(interp, infoPtr, -1, valuePtr); X if (result != TCL_OK) { X goto done; X } X if (infoPtr->token != CLOSE_PAREN) { X Tcl_ResetResult(interp); X sprintf(interp->result, X "unmatched parentheses in expression \"%.50s\"", X infoPtr->originalExpr); X result = TCL_ERROR; X goto done; X } X } else { X if (infoPtr->token == MINUS) { X infoPtr->token = UNARY_MINUS; X } X if (infoPtr->token >= UNARY_MINUS) { X X /* X * Process unary operators. X */ X X operator = infoPtr->token; X result = ExprGetValue(interp, infoPtr, precTable[infoPtr->token], X valuePtr); X if (result != TCL_OK) { X goto done; X } X switch (operator) { X case UNARY_MINUS: X if (valuePtr->type == TYPE_INT) { X valuePtr->intValue = -valuePtr->intValue; X } else if (valuePtr->type == TYPE_DOUBLE){ X valuePtr->doubleValue = -valuePtr->doubleValue; X } else { X badType = valuePtr->type; X goto illegalType; X } X break; X case NOT: X if (valuePtr->type == TYPE_INT) { X valuePtr->intValue = !valuePtr->intValue; X } else if (valuePtr->type == TYPE_DOUBLE) { X valuePtr->intValue = !valuePtr->doubleValue; X valuePtr->type = TYPE_INT; X } else { X badType = valuePtr->type; X goto illegalType; X } X break; X case BIT_NOT: X if (valuePtr->type == TYPE_INT) { X valuePtr->intValue = ~valuePtr->intValue; X } else { X badType = valuePtr->type; X goto illegalType; X } X break; X } X gotOp = 1; X } else if (infoPtr->token != VALUE) { X goto syntaxError; X } X } X X /* X * Got the first operand. Now fetch (operator, operand) pairs. X */ X X if (!gotOp) { X result = ExprLex(interp, infoPtr, &value2); X if (result != TCL_OK) { X goto done; X } X } X while (1) { X operator = infoPtr->token; X value2.pv.next = value2.pv.buffer; X if ((operator < MULT) || (operator >= UNARY_MINUS)) { X if ((operator == END) || (operator == CLOSE_PAREN)) { X result = TCL_OK; X goto done; X } else { X goto syntaxError; X } X } X if (precTable[operator] <= prec) { X result = TCL_OK; X goto done; X } X X /* X * If we're doing an AND or OR and the first operand already X * determines the result, don't execute anything in the X * second operand: just parse. Same style for ?: pairs. X */ X X if ((operator == AND) || (operator == OR) || (operator == QUESTY)) { X if (valuePtr->type == TYPE_DOUBLE) { X valuePtr->intValue = valuePtr->doubleValue != 0; X valuePtr->type = TYPE_INT; X } else if (valuePtr->type == TYPE_STRING) { X badType = TYPE_STRING; X goto illegalType; X } X if (((operator == AND) && !valuePtr->intValue) X || ((operator == OR) && valuePtr->intValue)) { X iPtr->noEval++; X result = ExprGetValue(interp, infoPtr, precTable[operator], X &value2); X iPtr->noEval--; X } else if (operator == QUESTY) { X if (valuePtr->intValue != 0) { X valuePtr->pv.next = valuePtr->pv.buffer; X result = ExprGetValue(interp, infoPtr, precTable[operator], X valuePtr); X if (result != TCL_OK) { X goto done; X } X if (infoPtr->token != COLON) { X goto syntaxError; X } X value2.pv.next = value2.pv.buffer; X iPtr->noEval++; X result = ExprGetValue(interp, infoPtr, precTable[operator], X &value2); X iPtr->noEval--; X } else { X iPtr->noEval++; X result = ExprGetValue(interp, infoPtr, precTable[operator], X &value2); X iPtr->noEval--; X if (result != TCL_OK) { X goto done; X } X if (infoPtr->token != COLON) { X goto syntaxError; X } X valuePtr->pv.next = valuePtr->pv.buffer; X result = ExprGetValue(interp, infoPtr, precTable[operator], X valuePtr); X } X } else { X result = ExprGetValue(interp, infoPtr, precTable[operator], X &value2); X } X } else { X result = ExprGetValue(interp, infoPtr, precTable[operator], X &value2); X } X if (result != TCL_OK) { X goto done; X } X if ((infoPtr->token < MULT) && (infoPtr->token != VALUE) X && (infoPtr->token != END) X && (infoPtr->token != CLOSE_PAREN)) { X goto syntaxError; X } X X /* X * At this point we've got two values and an operator. Check X * to make sure that the particular data types are appropriate X * for the particular operator, and perform type conversion X * if necessary. X */ X X switch (operator) { X X /* X * For the operators below, no strings are allowed and X * ints get converted to floats if necessary. X */ X X case MULT: case DIVIDE: case PLUS: case MINUS: X if ((valuePtr->type == TYPE_STRING) X || (value2.type == TYPE_STRING)) { X badType = TYPE_STRING; X goto illegalType; X } X if (valuePtr->type == TYPE_DOUBLE) { X if (value2.type == TYPE_INT) { X value2.doubleValue = value2.intValue; X value2.type = TYPE_DOUBLE; X } X } else if (value2.type == TYPE_DOUBLE) { X if (valuePtr->type == TYPE_INT) { X valuePtr->doubleValue = valuePtr->intValue; X valuePtr->type = TYPE_DOUBLE; X } X } X break; X X /* X * For the operators below, only integers are allowed. X */ X X case MOD: case LEFT_SHIFT: case RIGHT_SHIFT: X case BIT_AND: case BIT_XOR: case BIT_OR: X if (valuePtr->type != TYPE_INT) { X badType = valuePtr->type; X goto illegalType; X } else if (value2.type != TYPE_INT) { X badType = value2.type; X goto illegalType; X } X break; X X /* X * For the operators below, any type is allowed but the X * two operands must have the same type. Convert integers X * to floats and either to strings, if necessary. X */ X X case LESS: case GREATER: case LEQ: case GEQ: X case EQUAL: case NEQ: X if (valuePtr->type == TYPE_STRING) { X if (value2.type != TYPE_STRING) { X ExprMakeString(&value2); X } X } else if (value2.type == TYPE_STRING) { X if (valuePtr->type != TYPE_STRING) { X ExprMakeString(valuePtr); X } X } else if (valuePtr->type == TYPE_DOUBLE) { X if (value2.type == TYPE_INT) { X value2.doubleValue = value2.intValue; X value2.type = TYPE_DOUBLE; X } X } else if (value2.type == TYPE_DOUBLE) { X if (valuePtr->type == TYPE_INT) { X valuePtr->doubleValue = valuePtr->intValue; X valuePtr->type = TYPE_DOUBLE; X } X } X break; X X /* X * For the operators below, no strings are allowed, but X * no int->double conversions are performed. X */ X X case AND: case OR: X if (valuePtr->type == TYPE_STRING) { X badType = valuePtr->type; X goto illegalType; X } X if (value2.type == TYPE_STRING) { X badType = value2.type; X goto illegalType; X } X break; X X /* X * For the operators below, type and conversions are X * irrelevant: they're handled elsewhere. X */ X X case QUESTY: case COLON: X break; X X /* X * Any other operator is an error. X */ X X default: X interp->result = "unknown operator in expression"; X result = TCL_ERROR; X goto done; X } X X /* X * If necessary, convert one of the operands to the type X * of the other. If the operands are incompatible with X * the operator (e.g. "+" on strings) then return an X * error. X */ X X switch (operator) { X case MULT: X if (valuePtr->type == TYPE_INT) { X valuePtr->intValue *= value2.intValue; X } else { X valuePtr->doubleValue *= value2.doubleValue; X } X break; X case DIVIDE: X if (valuePtr->type == TYPE_INT) { X if (value2.intValue == 0) { X divideByZero: X interp->result = "divide by zero"; X result = TCL_ERROR; X goto done; X } X valuePtr->intValue /= value2.intValue; X } else { X if (value2.doubleValue == 0.0) { X goto divideByZero; X } X valuePtr->doubleValue /= value2.doubleValue; X } X break; X case MOD: X if (value2.intValue == 0) { X goto divideByZero; X } X valuePtr->intValue %= value2.intValue; X break; X case PLUS: X if (valuePtr->type == TYPE_INT) { X valuePtr->intValue += value2.intValue; X } else { X valuePtr->doubleValue += value2.doubleValue; X } X break; X case MINUS: X if (valuePtr->type == TYPE_INT) { X valuePtr->intValue -= value2.intValue; X } else { X valuePtr->doubleValue -= value2.doubleValue; X } X break; X case LEFT_SHIFT: X valuePtr->intValue <<= value2.intValue; X break; X case RIGHT_SHIFT: X /* X * The following code is a bit tricky: it ensures that X * right shifts propagate the sign bit even on machines X * where ">>" won't do it by default. X */ X X if (valuePtr->intValue < 0) { X valuePtr->intValue = X ~((~valuePtr->intValue) >> value2.intValue); X } else { X valuePtr->intValue >>= value2.intValue; X } X break; X case LESS: X if (valuePtr->type == TYPE_INT) { X valuePtr->intValue = X valuePtr->intValue < value2.intValue; X } else if (valuePtr->type == TYPE_DOUBLE) { X valuePtr->intValue = X valuePtr->doubleValue < value2.doubleValue; X } else { X valuePtr->intValue = X strcmp(valuePtr->pv.buffer, value2.pv.buffer) < 0; X } X valuePtr->type = TYPE_INT; X break; X case GREATER: X if (valuePtr->type == TYPE_INT) { X valuePtr->intValue = X valuePtr->intValue > value2.intValue; X } else if (valuePtr->type == TYPE_DOUBLE) { X valuePtr->intValue = X valuePtr->doubleValue > value2.doubleValue; X } else { X valuePtr->intValue = X strcmp(valuePtr->pv.buffer, value2.pv.buffer) > 0; X } X valuePtr->type = TYPE_INT; X break; X case LEQ: X if (valuePtr->type == TYPE_INT) { X valuePtr->intValue = X valuePtr->intValue <= value2.intValue; X } else if (valuePtr->type == TYPE_DOUBLE) { X valuePtr->intValue = X valuePtr->doubleValue <= value2.doubleValue; X } else { X valuePtr->intValue = X strcmp(valuePtr->pv.buffer, value2.pv.buffer) <= 0; X } X valuePtr->type = TYPE_INT; X break; X case GEQ: X if (valuePtr->type == TYPE_INT) { X valuePtr->intValue = X valuePtr->intValue >= value2.intValue; X } else if (valuePtr->type == TYPE_DOUBLE) { X valuePtr->intValue = X valuePtr->doubleValue >= value2.doubleValue; X } else { X valuePtr->intValue = X strcmp(valuePtr->pv.buffer, value2.pv.buffer) >= 0; X } X valuePtr->type = TYPE_INT; X break; X case EQUAL: X if (valuePtr->type == TYPE_INT) { X valuePtr->intValue = X valuePtr->intValue == value2.intValue; X } else if (valuePtr->type == TYPE_DOUBLE) { X valuePtr->intValue = X valuePtr->doubleValue == value2.doubleValue; X } else { X valuePtr->intValue = X strcmp(valuePtr->pv.buffer, value2.pv.buffer) == 0; X } X valuePtr->type = TYPE_INT; X break; X case NEQ: X if (valuePtr->type == TYPE_INT) { X valuePtr->intValue = X valuePtr->intValue != value2.intValue; X } else if (valuePtr->type == TYPE_DOUBLE) { X valuePtr->intValue = X valuePtr->doubleValue != value2.doubleValue; X } else { X valuePtr->intValue = X strcmp(valuePtr->pv.buffer, value2.pv.buffer) != 0; X } X valuePtr->type = TYPE_INT; X break; X case BIT_AND: X valuePtr->intValue &= value2.intValue; X break; X case BIT_XOR: X valuePtr->intValue ^= value2.intValue; X break; X case BIT_OR: X valuePtr->intValue |= value2.intValue; X break; X X /* X * For AND and OR, we know that the first value has already X * been converted to an integer. Thus we need only consider X * the possibility of int vs. double for the second value. X */ X X case AND: X if (value2.type == TYPE_DOUBLE) { X value2.intValue = value2.doubleValue != 0; X value2.type = TYPE_INT; X } X valuePtr->intValue = valuePtr->intValue && value2.intValue; X break; X case OR: X if (value2.type == TYPE_DOUBLE) { X value2.intValue = value2.doubleValue != 0; X value2.type = TYPE_INT; X } X valuePtr->intValue = valuePtr->intValue || value2.intValue; X break; X X case COLON: X interp->result = "can't have : operator without ? first"; X result = TCL_ERROR; X goto done; X } X } X X done: X if (value2.pv.buffer != value2.staticSpace) { X ckfree(value2.pv.buffer); X } X return result; X X syntaxError: X Tcl_ResetResult(interp); X Tcl_AppendResult(interp, "syntax error in expression \"", X infoPtr->originalExpr, "\"", (char *) NULL); X result = TCL_ERROR; X goto done; X X illegalType: X Tcl_AppendResult(interp, "can't use ", (badType == TYPE_DOUBLE) ? X "floating-point value" : "non-numeric string", X " as operand of \"", operatorStrings[operator], "\"", X (char *) NULL); X result = TCL_ERROR; X goto done; X} X X/* X *-------------------------------------------------------------- X * X * ExprMakeString -- X * X * Convert a value from int or double representation to X * a string. X * X * Results: X * The information at *valuePtr gets converted to string X * format, if it wasn't that way already. X * X * Side effects: X * None. X * X *-------------------------------------------------------------- X */ X Xstatic void XExprMakeString(valuePtr) X register Value *valuePtr; /* Value to be converted. */ X{ X int shortfall; X X shortfall = 150 - (valuePtr->pv.end - valuePtr->pv.buffer); X if (shortfall > 0) { X (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall); X } X if (valuePtr->type == TYPE_INT) { X sprintf(valuePtr->pv.buffer, "%ld", valuePtr->intValue); X } else if (valuePtr->type == TYPE_DOUBLE) { X sprintf(valuePtr->pv.buffer, "%g", valuePtr->doubleValue); X } X valuePtr->type = TYPE_STRING; X} X X/* X *-------------------------------------------------------------- X * X * ExprTopLevel -- X * X * This procedure provides top-level functionality shared by X * procedures like Tcl_ExprInt, Tcl_ExprDouble, etc. X * X * Results: X * The result is a standard Tcl return value. If an error X * occurs then an error message is left in interp->result. X * The value of the expression is returned in *valuePtr, in X * whatever form it ends up in (could be string or integer X * or double). Caller may need to convert result. Caller X * is also responsible for freeing string memory in *valuePtr, X * if any was allocated. X * X * Side effects: X * None. X * X *-------------------------------------------------------------- X */ X Xstatic int XExprTopLevel(interp, string, valuePtr) X Tcl_Interp *interp; /* Context in which to evaluate the X * expression. */ X char *string; /* Expression to evaluate. */ X Value *valuePtr; /* Where to store result. Should X * not be initialized by caller. */ X{ X ExprInfo info; X int result; X X info.originalExpr = string; X info.expr = string; X valuePtr->pv.buffer = valuePtr->pv.next = valuePtr->staticSpace; X valuePtr->pv.end = valuePtr->pv.buffer + STATIC_STRING_SPACE - 1; X valuePtr->pv.expandProc = TclExpandParseValue; X valuePtr->pv.clientData = (ClientData) NULL; X X result = ExprGetValue(interp, &info, -1, valuePtr); X if (result != TCL_OK) { X return result; X } X if (info.token != END) { X Tcl_AppendResult(interp, "syntax error in expression \"", X string, "\"", (char *) NULL); X return TCL_ERROR; X } X return TCL_OK; X} X X/* X *-------------------------------------------------------------- X * X * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean -- X * X * Procedures to evaluate an expression and return its value X * in a particular form. X * X * Results: X * Each of the procedures below returns a standard Tcl result. X * If an error occurs then an error message is left in X * interp->result. Otherwise the value of the expression, X * in the appropriate form, is stored at *resultPtr. If X * the expression had a result that was incompatible with the X * desired form then an error is returned. X * X * Side effects: X * None. X * X *-------------------------------------------------------------- X */ X Xint XTcl_ExprLong(interp, string, ptr) X Tcl_Interp *interp; /* Context in which to evaluate the X * expression. */ X char *string; /* Expression to evaluate. */ X long *ptr; /* Where to store result. */ X{ X Value value; X int result; X X result = ExprTopLevel(interp, string, &value); X if (result == TCL_OK) { X if (value.type == TYPE_INT) { X *ptr = value.intValue; X } else if (value.type == TYPE_DOUBLE) { X *ptr = value.doubleValue; X } else { X interp->result = "expression didn't have numeric value"; X result = TCL_ERROR; X } X } X if (value.pv.buffer != value.staticSpace) { X ckfree(value.pv.buffer); X } X return result; X} X Xint XTcl_ExprDouble(interp, string, ptr) X Tcl_Interp *interp; /* Context in which to evaluate the X * expression. */ X char *string; /* Expression to evaluate. */ X double *ptr; /* Where to store result. */ X{ X Value value; X int result; X X result = ExprTopLevel(interp, string, &value); X if (result == TCL_OK) { X if (value.type == TYPE_INT) { X *ptr = value.intValue; X } else if (value.type == TYPE_DOUBLE) { X *ptr = value.doubleValue; X } else { X interp->result = "expression didn't have numeric value"; X result = TCL_ERROR; X } X } X if (value.pv.buffer != value.staticSpace) { X ckfree(value.pv.buffer); X } X return result; X} X Xint XTcl_ExprBoolean(interp, string, ptr) X Tcl_Interp *interp; /* Context in which to evaluate the X * expression. */ X char *string; /* Expression to evaluate. */ X int *ptr; /* Where to store 0/1 result. */ X{ X Value value; X int result; X X result = ExprTopLevel(interp, string, &value); X if (result == TCL_OK) { X if (value.type == TYPE_INT) { X *ptr = value.intValue != 0; X } else if (value.type == TYPE_DOUBLE) { X *ptr = value.doubleValue != 0.0; X } else { X interp->result = "expression didn't have numeric value"; X result = TCL_ERROR; X } X } X if (value.pv.buffer != value.staticSpace) { X ckfree(value.pv.buffer); X } X return result; X} X X/* X *-------------------------------------------------------------- X * X * Tcl_ExprString -- X * X * Evaluate an expression and return its value in string form. X * X * Results: X * A standard Tcl result. If the result is TCL_OK, then the X * interpreter's result is set to the string value of the X * expression. If the result is TCL_OK, then interp->result X * contains an error message. X * X * Side effects: X * None. X * X *-------------------------------------------------------------- X */ X Xint XTcl_ExprString(interp, string) X Tcl_Interp *interp; /* Context in which to evaluate the X * expression. */ X char *string; /* Expression to evaluate. */ X{ X Value value; X int result; X X result = ExprTopLevel(interp, string, &value); X if (result == TCL_OK) { X if (value.type == TYPE_INT) { X sprintf(interp->result, "%ld", value.intValue); X } else if (value.type == TYPE_DOUBLE) { X sprintf(interp->result, "%g", value.doubleValue); X } else { X if (value.pv.buffer != value.staticSpace) { X interp->result = value.pv.buffer; X interp->freeProc = (Tcl_FreeProc *) free; X value.pv.buffer = value.staticSpace; X } else { X Tcl_SetResult(interp, value.pv.buffer, TCL_VOLATILE); X } X } X } X if (value.pv.buffer != value.staticSpace) { X ckfree(value.pv.buffer); X } X return result; X} END_OF_FILE if test 34117 -ne `wc -c <'tcl6.1/tclExpr.c'`; then echo shar: \"'tcl6.1/tclExpr.c'\" unpacked with wrong size! fi # end of 'tcl6.1/tclExpr.c' fi echo shar: End of archive 26 \(of 33\). cp /dev/null ark26isdone MISSING="" for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 ; do if test ! -f ark${I}isdone ; then MISSING="${MISSING} ${I}" fi done if test "${MISSING}" = "" ; then echo You have unpacked all 33 archives. rm -f ark[1-9]isdone ark[1-9][0-9]isdone else echo You still need to unpack the following archives: echo " " ${MISSING} fi ## End of shell archive. exit 0 exit 0 # Just in case... -- Kent Landfield INTERNET: kent@sparky.IMD.Sterling.COM Sterling Software, IMD UUCP: uunet!sparky!kent Phone: (402) 291-8300 FAX: (402) 291-4362 Please send comp.sources.misc-related mail to kent@uunet.uu.net.