Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/misc/volume25/tcl/part26

Text File | 1991-11-15 | 36.7 KB | 1,388 lines

Newsgroups: comp.sources.misc
From: [e-mail] (Karl Lehenbauer)
Subject:  v25i094:  tcl - tool command language, version 6.1, Part26/33
Message-ID: <[e-mail]>
X-Md4-Signature: 2751a496be310cba7ed012820f0ea459
Date: Fri, 15 Nov 1991 22:55:35 GMT
Approved: [e-mail]

Submitted-by: [e-mail] (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 <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 26 (of 33)."
# Contents:  tcl6.1/tclExpr.c
# Wrapped by karl@one on Tue Nov 12 19:44:30 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'tcl6.1/tclExpr.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'tcl6.1/tclExpr.c'\"
else
echo shar: Extracting \"'tcl6.1/tclExpr.c'\" \(34117 characters\)
sed "s/^X//" >'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: [e-mail]
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    [phone]         FAX:      [phone]
Please send comp.sources.misc-related mail to [e-mail].