home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tkisrc04.zip / tcl / os2 / tclExpr.c < prev    next >
C/C++ Source or Header  |  1998-08-07  |  55KB  |  2,056 lines
  1. /* 
  2.  * tclExpr.c --
  3.  *
  4.  *    This file contains the code to evaluate expressions for
  5.  *    Tcl.
  6.  *
  7.  *    This implementation of floating-point support was modelled
  8.  *    after an initial implementation by Bill Carpenter.
  9.  *
  10.  * Copyright (c) 1987-1994 The Regents of the University of California.
  11.  * Copyright (c) 1994 Sun Microsystems, Inc.
  12.  *
  13.  * See the file "license.terms" for information on usage and redistribution
  14.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15.  *
  16.  * SCCS: @(#) tclExpr.c 1.91 96/02/15 11:42:44
  17.  */
  18.  
  19. #include "tclInt.h"
  20. #ifdef NO_FLOAT_H
  21. #   include "../compat/float.h"
  22. #else
  23. #   include <float.h>
  24. #endif
  25. #ifndef TCL_NO_MATH
  26. #include <math.h>
  27. #endif
  28.  
  29. /*
  30.  * The stuff below is a bit of a hack so that this file can be used
  31.  * in environments that include no UNIX, i.e. no errno.  Just define
  32.  * errno here.
  33.  */
  34.  
  35. #ifndef TCL_GENERIC_ONLY
  36. #include "tclPort.h"
  37. #else
  38. #define NO_ERRNO_H
  39. #endif
  40.  
  41. #ifdef NO_ERRNO_H
  42. int errno;
  43. #define EDOM 33
  44. #define ERANGE 34
  45. #endif
  46.  
  47. /*
  48.  * The data structure below is used to describe an expression value,
  49.  * which can be either an integer (the usual case), a double-precision
  50.  * floating-point value, or a string.  A given number has only one
  51.  * value at a time.
  52.  */
  53.  
  54. #define STATIC_STRING_SPACE 150
  55.  
  56. typedef struct {
  57.     long intValue;        /* Integer value, if any. */
  58.     double  doubleValue;    /* Floating-point value, if any. */
  59.     ParseValue pv;        /* Used to hold a string value, if any. */
  60.     char staticSpace[STATIC_STRING_SPACE];
  61.                 /* Storage for small strings;  large ones
  62.                  * are malloc-ed. */
  63.     int type;            /* Type of value:  TYPE_INT, TYPE_DOUBLE,
  64.                  * or TYPE_STRING. */
  65. } Value;
  66.  
  67. /*
  68.  * Valid values for type:
  69.  */
  70.  
  71. #define TYPE_INT    0
  72. #define TYPE_DOUBLE    1
  73. #define TYPE_STRING    2
  74.  
  75. /*
  76.  * The data structure below describes the state of parsing an expression.
  77.  * It's passed among the routines in this module.
  78.  */
  79.  
  80. typedef struct {
  81.     char *originalExpr;        /* The entire expression, as originally
  82.                  * passed to Tcl_ExprString et al. */
  83.     char *expr;            /* Position to the next character to be
  84.                  * scanned from the expression string. */
  85.     int token;            /* Type of the last token to be parsed from
  86.                  * expr.  See below for definitions.
  87.                  * Corresponds to the characters just
  88.                  * before expr. */
  89. } ExprInfo;
  90.  
  91. /*
  92.  * The token types are defined below.  In addition, there is a table
  93.  * associating a precedence with each operator.  The order of types
  94.  * is important.  Consult the code before changing it.
  95.  */
  96.  
  97. #define VALUE        0
  98. #define OPEN_PAREN    1
  99. #define CLOSE_PAREN    2
  100. #define COMMA        3
  101. #define END        4
  102. #define UNKNOWN        5
  103.  
  104. /*
  105.  * Binary operators:
  106.  */
  107.  
  108. #define MULT        8
  109. #define DIVIDE        9
  110. #define MOD        10
  111. #define PLUS        11
  112. #define MINUS        12
  113. #define LEFT_SHIFT    13
  114. #define RIGHT_SHIFT    14
  115. #define LESS        15
  116. #define GREATER        16
  117. #define LEQ        17
  118. #define GEQ        18
  119. #define EQUAL        19
  120. #define NEQ        20
  121. #define BIT_AND        21
  122. #define BIT_XOR        22
  123. #define BIT_OR        23
  124. #define AND        24
  125. #define OR        25
  126. #define QUESTY        26
  127. #define COLON        27
  128.  
  129. /*
  130.  * Unary operators:
  131.  */
  132.  
  133. #define    UNARY_MINUS    28
  134. #define UNARY_PLUS    29
  135. #define NOT        30
  136. #define BIT_NOT        31
  137.  
  138. /*
  139.  * Precedence table.  The values for non-operator token types are ignored.
  140.  */
  141.  
  142. static int precTable[] = {
  143.     0, 0, 0, 0, 0, 0, 0, 0,
  144.     12, 12, 12,                /* MULT, DIVIDE, MOD */
  145.     11, 11,                /* PLUS, MINUS */
  146.     10, 10,                /* LEFT_SHIFT, RIGHT_SHIFT */
  147.     9, 9, 9, 9,                /* LESS, GREATER, LEQ, GEQ */
  148.     8, 8,                /* EQUAL, NEQ */
  149.     7,                    /* BIT_AND */
  150.     6,                    /* BIT_XOR */
  151.     5,                    /* BIT_OR */
  152.     4,                    /* AND */
  153.     3,                    /* OR */
  154.     2,                    /* QUESTY */
  155.     1,                    /* COLON */
  156.     13, 13, 13, 13            /* UNARY_MINUS, UNARY_PLUS, NOT,
  157.                      * BIT_NOT */
  158. };
  159.  
  160. /*
  161.  * Mapping from operator numbers to strings;  used for error messages.
  162.  */
  163.  
  164. static char *operatorStrings[] = {
  165.     "VALUE", "(", ")", ",", "END", "UNKNOWN", "6", "7",
  166.     "*", "/", "%", "+", "-", "<<", ">>", "<", ">", "<=",
  167.     ">=", "==", "!=", "&", "^", "|", "&&", "||", "?", ":",
  168.     "-", "+", "!", "~"
  169. };
  170.  
  171. /*
  172.  * The following slight modification to DBL_MAX is needed because of
  173.  * a compiler bug on Sprite (4/15/93).
  174.  */
  175.  
  176. #ifdef sprite
  177. #undef DBL_MAX
  178. #define DBL_MAX 1.797693134862316e+307
  179. #endif
  180.  
  181. /*
  182.  * Macros for testing floating-point values for certain special
  183.  * cases.  Test for not-a-number by comparing a value against
  184.  * itself;  test for infinity by comparing against the largest
  185.  * floating-point value.
  186.  */
  187.  
  188. #define IS_NAN(v) ((v) != (v))
  189. #ifdef DBL_MAX
  190. #   define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX))
  191. #else
  192. #   define IS_INF(v) 0
  193. #endif
  194.  
  195. /*
  196.  * The following global variable is use to signal matherr that Tcl
  197.  * is responsible for the arithmetic, so errors can be handled in a
  198.  * fashion appropriate for Tcl.  Zero means no Tcl math is in
  199.  * progress;  non-zero means Tcl is doing math.
  200.  */
  201.  
  202. int tcl_MathInProgress = 0;
  203.  
  204. /*
  205.  * The variable below serves no useful purpose except to generate
  206.  * a reference to matherr, so that the Tcl version of matherr is
  207.  * linked in rather than the system version.  Without this reference
  208.  * the need for matherr won't be discovered during linking until after
  209.  * libtcl.a has been processed, so Tcl's version won't be used.
  210.  */
  211.  
  212. #ifdef NEED_MATHERR
  213. extern int matherr();
  214. int (*tclMatherrPtr)() = matherr;
  215. #endif
  216.  
  217. /*
  218.  * Declarations for local procedures to this file:
  219.  */
  220.  
  221. static int        ExprAbsFunc _ANSI_ARGS_((ClientData clientData,
  222.                 Tcl_Interp *interp, Tcl_Value *args,
  223.                 Tcl_Value *resultPtr));
  224. static int        ExprBinaryFunc _ANSI_ARGS_((ClientData clientData,
  225.                 Tcl_Interp *interp, Tcl_Value *args,
  226.                 Tcl_Value *resultPtr));
  227. static int        ExprDoubleFunc _ANSI_ARGS_((ClientData clientData,
  228.                 Tcl_Interp *interp, Tcl_Value *args,
  229.                 Tcl_Value *resultPtr));
  230. static int        ExprGetValue _ANSI_ARGS_((Tcl_Interp *interp,
  231.                 ExprInfo *infoPtr, int prec, Value *valuePtr));
  232. static int        ExprIntFunc _ANSI_ARGS_((ClientData clientData,
  233.                 Tcl_Interp *interp, Tcl_Value *args,
  234.                 Tcl_Value *resultPtr));
  235. static int        ExprLex _ANSI_ARGS_((Tcl_Interp *interp,
  236.                 ExprInfo *infoPtr, Value *valuePtr));
  237. static int        ExprLooksLikeInt _ANSI_ARGS_((char *p));
  238. static void        ExprMakeString _ANSI_ARGS_((Tcl_Interp *interp,
  239.                 Value *valuePtr));
  240. static int        ExprMathFunc _ANSI_ARGS_((Tcl_Interp *interp,
  241.                 ExprInfo *infoPtr, Value *valuePtr));
  242. static int        ExprParseString _ANSI_ARGS_((Tcl_Interp *interp,
  243.                 char *string, Value *valuePtr));
  244. static int        ExprRoundFunc _ANSI_ARGS_((ClientData clientData,
  245.                 Tcl_Interp *interp, Tcl_Value *args,
  246.                 Tcl_Value *resultPtr));
  247. static int        ExprTopLevel _ANSI_ARGS_((Tcl_Interp *interp,
  248.                 char *string, Value *valuePtr));
  249. static int        ExprUnaryFunc _ANSI_ARGS_((ClientData clientData,
  250.                 Tcl_Interp *interp, Tcl_Value *args,
  251.                 Tcl_Value *resultPtr));
  252.  
  253. /*
  254.  * Built-in math functions:
  255.  */
  256.  
  257. typedef struct {
  258.     char *name;            /* Name of function. */
  259.     int numArgs;        /* Number of arguments for function. */
  260.     Tcl_ValueType argTypes[MAX_MATH_ARGS];
  261.                 /* Acceptable types for each argument. */
  262.     Tcl_MathProc *proc;        /* Procedure that implements this function. */
  263.     ClientData clientData;    /* Additional argument to pass to the function
  264.                  * when invoking it. */
  265. } BuiltinFunc;
  266.  
  267. static BuiltinFunc funcTable[] = {
  268. #ifndef TCL_NO_MATH
  269.     {"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos},
  270.     {"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin},
  271.     {"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan},
  272.     {"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2},
  273.     {"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil},
  274.     {"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos},
  275.     {"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh},
  276.     {"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp},
  277.     {"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor},
  278.     {"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod},
  279.     {"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot},
  280.     {"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log},
  281.     {"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10},
  282.     {"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow},
  283.     {"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin},
  284.     {"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh},
  285.     {"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt},
  286.     {"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan},
  287.     {"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh},
  288. #endif
  289.     {"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0},
  290.     {"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0},
  291.     {"int", 1, {TCL_EITHER}, ExprIntFunc, 0},
  292.     {"round", 1, {TCL_EITHER}, ExprRoundFunc, 0},
  293.  
  294.     {0},
  295. };
  296.  
  297. /*
  298.  *--------------------------------------------------------------
  299.  *
  300.  * ExprParseString --
  301.  *
  302.  *    Given a string (such as one coming from command or variable
  303.  *    substitution), make a Value based on the string.  The value
  304.  *    will be a floating-point or integer, if possible, or else it
  305.  *    will just be a copy of the string.
  306.  *
  307.  * Results:
  308.  *    TCL_OK is returned under normal circumstances, and TCL_ERROR
  309.  *    is returned if a floating-point overflow or underflow occurred
  310.  *    while reading in a number.  The value at *valuePtr is modified
  311.  *    to hold a number, if possible.
  312.  *
  313.  * Side effects:
  314.  *    None.
  315.  *
  316.  *--------------------------------------------------------------
  317.  */
  318.  
  319. static int
  320. ExprParseString(interp, string, valuePtr)
  321.     Tcl_Interp *interp;        /* Where to store error message. */
  322.     char *string;        /* String to turn into value. */
  323.     Value *valuePtr;        /* Where to store value information. 
  324.                  * Caller must have initialized pv field. */
  325. {
  326.     char *term, *p, *start;
  327.  
  328.     if (*string != 0) {
  329.     if (ExprLooksLikeInt(string)) {
  330.         valuePtr->type = TYPE_INT;
  331.         errno = 0;
  332.     
  333.         /*
  334.          * Note: use strtoul instead of strtol for integer conversions
  335.          * to allow full-size unsigned numbers, but don't depend on
  336.          * strtoul to handle sign characters;  it won't in some
  337.          * implementations.
  338.          */
  339.     
  340.         for (p = string; isspace(UCHAR(*p)); p++) {
  341.         /* Empty loop body. */
  342.         }
  343.         if (*p == '-') {
  344.         start = p+1;
  345.         valuePtr->intValue = -((int)strtoul(start, &term, 0));
  346.         } else if (*p == '+') {
  347.         start = p+1;
  348.         valuePtr->intValue = strtoul(start, &term, 0);
  349.         } else {
  350.         start = p;
  351.         valuePtr->intValue = strtoul(start, &term, 0);
  352.         }
  353.         if (*term == 0) {
  354.         if (errno == ERANGE) {
  355.             /*
  356.              * This procedure is sometimes called with string in
  357.              * interp->result, so we have to clear the result before
  358.              * logging an error message.
  359.              */
  360.     
  361.             Tcl_ResetResult(interp);
  362.             interp->result = "integer value too large to represent";
  363.             Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
  364.                 interp->result, (char *) NULL);
  365.             return TCL_ERROR;
  366.         } else {
  367.             return TCL_OK;
  368.         }
  369.         }
  370.     } else {
  371.         errno = 0;
  372.         valuePtr->doubleValue = strtod(string, &term);
  373.         if ((term != string) && (*term == 0)) {
  374.         if (errno != 0) {
  375.             Tcl_ResetResult(interp);
  376.             TclExprFloatError(interp, valuePtr->doubleValue);
  377.             return TCL_ERROR;
  378.         }
  379.         valuePtr->type = TYPE_DOUBLE;
  380.         return TCL_OK;
  381.         }
  382.     }
  383.     }
  384.  
  385.     /*
  386.      * Not a valid number.  Save a string value (but don't do anything
  387.      * if it's already the value).
  388.      */
  389.  
  390.     valuePtr->type = TYPE_STRING;
  391.     if (string != valuePtr->pv.buffer) {
  392.     int length, shortfall;
  393.  
  394.     length = strlen(string);
  395.     valuePtr->pv.next = valuePtr->pv.buffer;
  396.     shortfall = length - (valuePtr->pv.end - valuePtr->pv.buffer);
  397.     if (shortfall > 0) {
  398.         (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall);
  399.     }
  400.     strcpy(valuePtr->pv.buffer, string);
  401.     }
  402.     return TCL_OK;
  403. }
  404.  
  405. /*
  406.  *----------------------------------------------------------------------
  407.  *
  408.  * ExprLex --
  409.  *
  410.  *    Lexical analyzer for expression parser:  parses a single value,
  411.  *    operator, or other syntactic element from an expression string.
  412.  *
  413.  * Results:
  414.  *    TCL_OK is returned unless an error occurred while doing lexical
  415.  *    analysis or executing an embedded command.  In that case a
  416.  *    standard Tcl error is returned, using interp->result to hold
  417.  *    an error message.  In the event of a successful return, the token
  418.  *    and field in infoPtr is updated to refer to the next symbol in
  419.  *    the expression string, and the expr field is advanced past that
  420.  *    token;  if the token is a value, then the value is stored at
  421.  *    valuePtr.
  422.  *
  423.  * Side effects:
  424.  *    None.
  425.  *
  426.  *----------------------------------------------------------------------
  427.  */
  428.  
  429. static int
  430. ExprLex(interp, infoPtr, valuePtr)
  431.     Tcl_Interp *interp;            /* Interpreter to use for error
  432.                      * reporting. */
  433.     register ExprInfo *infoPtr;        /* Describes the state of the parse. */
  434.     register Value *valuePtr;        /* Where to store value, if that is
  435.                      * what's parsed from string.  Caller
  436.                      * must have initialized pv field
  437.                      * correctly. */
  438. {
  439.     register char *p;
  440.     char *var, *term;
  441.     int result;
  442.  
  443.     p = infoPtr->expr;
  444.     while (isspace(UCHAR(*p))) {
  445.     p++;
  446.     }
  447.     if (*p == 0) {
  448.     infoPtr->token = END;
  449.     infoPtr->expr = p;
  450.     return TCL_OK;
  451.     }
  452.  
  453.     /*
  454.      * First try to parse the token as an integer or floating-point number.
  455.      * Don't want to check for a number if the first character is "+"
  456.      * or "-".  If we do, we might treat a binary operator as unary by
  457.      * mistake, which will eventually cause a syntax error.
  458.      */
  459.  
  460.     if ((*p != '+')  && (*p != '-')) {
  461.     if (ExprLooksLikeInt(p)) {
  462.         errno = 0;
  463.         valuePtr->intValue = strtoul(p, &term, 0);
  464.         if (errno == ERANGE) {
  465.         interp->result = "integer value too large to represent";
  466.         Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
  467.             interp->result, (char *) NULL);
  468.         return TCL_ERROR;
  469.         }
  470.         infoPtr->token = VALUE;
  471.         infoPtr->expr = term;
  472.         valuePtr->type = TYPE_INT;
  473.         return TCL_OK;
  474.     } else {
  475.         errno = 0;
  476.         valuePtr->doubleValue = strtod(p, &term);
  477.         if (term != p) {
  478.         if (errno != 0) {
  479.             TclExprFloatError(interp, valuePtr->doubleValue);
  480.             return TCL_ERROR;
  481.         }
  482.         infoPtr->token = VALUE;
  483.         infoPtr->expr = term;
  484.         valuePtr->type = TYPE_DOUBLE;
  485.         return TCL_OK;
  486.         }
  487.     }
  488.     }
  489.  
  490.     infoPtr->expr = p+1;
  491.     switch (*p) {
  492.     case '$':
  493.  
  494.         /*
  495.          * Variable.  Fetch its value, then see if it makes sense
  496.          * as an integer or floating-point number.
  497.          */
  498.  
  499.         infoPtr->token = VALUE;
  500.         var = Tcl_ParseVar(interp, p, &infoPtr->expr);
  501.         if (var == NULL) {
  502.         return TCL_ERROR;
  503.         }
  504.         Tcl_ResetResult(interp);
  505.         if (((Interp *) interp)->noEval) {
  506.         valuePtr->type = TYPE_INT;
  507.         valuePtr->intValue = 0;
  508.         return TCL_OK;
  509.         }
  510.         return ExprParseString(interp, var, valuePtr);
  511.  
  512.     case '[':
  513.         infoPtr->token = VALUE;
  514.         ((Interp *) interp)->evalFlags = TCL_BRACKET_TERM;
  515.         result = Tcl_Eval(interp, p+1);
  516.         infoPtr->expr = ((Interp *) interp)->termPtr;
  517.         if (result != TCL_OK) {
  518.         return result;
  519.         }
  520.         infoPtr->expr++;
  521.         if (((Interp *) interp)->noEval) {
  522.         valuePtr->type = TYPE_INT;
  523.         valuePtr->intValue = 0;
  524.         Tcl_ResetResult(interp);
  525.         return TCL_OK;
  526.         }
  527.         result = ExprParseString(interp, interp->result, valuePtr);
  528.         if (result != TCL_OK) {
  529.         return result;
  530.         }
  531.         Tcl_ResetResult(interp);
  532.         return TCL_OK;
  533.  
  534.     case '"':
  535.         infoPtr->token = VALUE;
  536.         result = TclParseQuotes(interp, infoPtr->expr, '"', 0,
  537.             &infoPtr->expr, &valuePtr->pv);
  538.         if (result != TCL_OK) {
  539.         return result;
  540.         }
  541.         Tcl_ResetResult(interp);
  542.         return ExprParseString(interp, valuePtr->pv.buffer, valuePtr);
  543.  
  544.     case '{':
  545.         infoPtr->token = VALUE;
  546.         result = TclParseBraces(interp, infoPtr->expr, &infoPtr->expr,
  547.             &valuePtr->pv);
  548.         if (result != TCL_OK) {
  549.         return result;
  550.         }
  551.         Tcl_ResetResult(interp);
  552.         return ExprParseString(interp, valuePtr->pv.buffer, valuePtr);
  553.  
  554.     case '(':
  555.         infoPtr->token = OPEN_PAREN;
  556.         return TCL_OK;
  557.  
  558.     case ')':
  559.         infoPtr->token = CLOSE_PAREN;
  560.         return TCL_OK;
  561.  
  562.     case ',':
  563.         infoPtr->token = COMMA;
  564.         return TCL_OK;
  565.  
  566.     case '*':
  567.         infoPtr->token = MULT;
  568.         return TCL_OK;
  569.  
  570.     case '/':
  571.         infoPtr->token = DIVIDE;
  572.         return TCL_OK;
  573.  
  574.     case '%':
  575.         infoPtr->token = MOD;
  576.         return TCL_OK;
  577.  
  578.     case '+':
  579.         infoPtr->token = PLUS;
  580.         return TCL_OK;
  581.  
  582.     case '-':
  583.         infoPtr->token = MINUS;
  584.         return TCL_OK;
  585.  
  586.     case '?':
  587.         infoPtr->token = QUESTY;
  588.         return TCL_OK;
  589.  
  590.     case ':':
  591.         infoPtr->token = COLON;
  592.         return TCL_OK;
  593.  
  594.     case '<':
  595.         switch (p[1]) {
  596.         case '<':
  597.             infoPtr->expr = p+2;
  598.             infoPtr->token = LEFT_SHIFT;
  599.             break;
  600.         case '=':
  601.             infoPtr->expr = p+2;
  602.             infoPtr->token = LEQ;
  603.             break;
  604.         default:
  605.             infoPtr->token = LESS;
  606.             break;
  607.         }
  608.         return TCL_OK;
  609.  
  610.     case '>':
  611.         switch (p[1]) {
  612.         case '>':
  613.             infoPtr->expr = p+2;
  614.             infoPtr->token = RIGHT_SHIFT;
  615.             break;
  616.         case '=':
  617.             infoPtr->expr = p+2;
  618.             infoPtr->token = GEQ;
  619.             break;
  620.         default:
  621.             infoPtr->token = GREATER;
  622.             break;
  623.         }
  624.         return TCL_OK;
  625.  
  626.     case '=':
  627.         if (p[1] == '=') {
  628.         infoPtr->expr = p+2;
  629.         infoPtr->token = EQUAL;
  630.         } else {
  631.         infoPtr->token = UNKNOWN;
  632.         }
  633.         return TCL_OK;
  634.  
  635.     case '!':
  636.         if (p[1] == '=') {
  637.         infoPtr->expr = p+2;
  638.         infoPtr->token = NEQ;
  639.         } else {
  640.         infoPtr->token = NOT;
  641.         }
  642.         return TCL_OK;
  643.  
  644.     case '&':
  645.         if (p[1] == '&') {
  646.         infoPtr->expr = p+2;
  647.         infoPtr->token = AND;
  648.         } else {
  649.         infoPtr->token = BIT_AND;
  650.         }
  651.         return TCL_OK;
  652.  
  653.     case '^':
  654.         infoPtr->token = BIT_XOR;
  655.         return TCL_OK;
  656.  
  657.     case '|':
  658.         if (p[1] == '|') {
  659.         infoPtr->expr = p+2;
  660.         infoPtr->token = OR;
  661.         } else {
  662.         infoPtr->token = BIT_OR;
  663.         }
  664.         return TCL_OK;
  665.  
  666.     case '~':
  667.         infoPtr->token = BIT_NOT;
  668.         return TCL_OK;
  669.  
  670.     default:
  671.         if (isalpha(UCHAR(*p))) {
  672.         infoPtr->expr = p;
  673.         return ExprMathFunc(interp, infoPtr, valuePtr);
  674.         }
  675.         infoPtr->expr = p+1;
  676.         infoPtr->token = UNKNOWN;
  677.         return TCL_OK;
  678.     }
  679. }
  680.  
  681. /*
  682.  *----------------------------------------------------------------------
  683.  *
  684.  * ExprGetValue --
  685.  *
  686.  *    Parse a "value" from the remainder of the expression in infoPtr.
  687.  *
  688.  * Results:
  689.  *    Normally TCL_OK is returned.  The value of the expression is
  690.  *    returned in *valuePtr.  If an error occurred, then interp->result
  691.  *    contains an error message and TCL_ERROR is returned.
  692.  *    InfoPtr->token will be left pointing to the token AFTER the
  693.  *    expression, and infoPtr->expr will point to the character just
  694.  *    after the terminating token.
  695.  *
  696.  * Side effects:
  697.  *    None.
  698.  *
  699.  *----------------------------------------------------------------------
  700.  */
  701.  
  702. static int
  703. ExprGetValue(interp, infoPtr, prec, valuePtr)
  704.     Tcl_Interp *interp;            /* Interpreter to use for error
  705.                      * reporting. */
  706.     register ExprInfo *infoPtr;        /* Describes the state of the parse
  707.                      * just before the value (i.e. ExprLex
  708.                      * will be called to get first token
  709.                      * of value). */
  710.     int prec;                /* Treat any un-parenthesized operator
  711.                      * with precedence <= this as the end
  712.                      * of the expression. */
  713.     Value *valuePtr;            /* Where to store the value of the
  714.                      * expression.   Caller must have
  715.                      * initialized pv field. */
  716. {
  717.     Interp *iPtr = (Interp *) interp;
  718.     Value value2;            /* Second operand for current
  719.                      * operator.  */
  720.     int operator;            /* Current operator (either unary
  721.                      * or binary). */
  722.     int badType;            /* Type of offending argument;  used
  723.                      * for error messages. */
  724.     int gotOp;                /* Non-zero means already lexed the
  725.                      * operator (while picking up value
  726.                      * for unary operator).  Don't lex
  727.                      * again. */
  728.     int result;
  729.  
  730.     /*
  731.      * There are two phases to this procedure.  First, pick off an initial
  732.      * value.  Then, parse (binary operator, value) pairs until done.
  733.      */
  734.  
  735.     gotOp = 0;
  736.     value2.pv.buffer = value2.pv.next = value2.staticSpace;
  737.     value2.pv.end = value2.pv.buffer + STATIC_STRING_SPACE - 1;
  738.     value2.pv.expandProc = TclExpandParseValue;
  739.     value2.pv.clientData = (ClientData) NULL;
  740.     result = ExprLex(interp, infoPtr, valuePtr);
  741.     if (result != TCL_OK) {
  742.     goto done;
  743.     }
  744.     if (infoPtr->token == OPEN_PAREN) {
  745.  
  746.     /*
  747.      * Parenthesized sub-expression.
  748.      */
  749.  
  750.     result = ExprGetValue(interp, infoPtr, -1, valuePtr);
  751.     if (result != TCL_OK) {
  752.         goto done;
  753.     }
  754.     if (infoPtr->token != CLOSE_PAREN) {
  755.         Tcl_AppendResult(interp, "unmatched parentheses in expression \"",
  756.             infoPtr->originalExpr, "\"", (char *) NULL);
  757.         result = TCL_ERROR;
  758.         goto done;
  759.     }
  760.     } else {
  761.     if (infoPtr->token == MINUS) {
  762.         infoPtr->token = UNARY_MINUS;
  763.     }
  764.     if (infoPtr->token == PLUS) {
  765.         infoPtr->token = UNARY_PLUS;
  766.     }
  767.     if (infoPtr->token >= UNARY_MINUS) {
  768.  
  769.         /*
  770.          * Process unary operators.
  771.          */
  772.  
  773.         operator = infoPtr->token;
  774.         result = ExprGetValue(interp, infoPtr, precTable[infoPtr->token],
  775.             valuePtr);
  776.         if (result != TCL_OK) {
  777.         goto done;
  778.         }
  779.         if (!iPtr->noEval) {
  780.         switch (operator) {
  781.             case UNARY_MINUS:
  782.             if (valuePtr->type == TYPE_INT) {
  783.                 valuePtr->intValue = -valuePtr->intValue;
  784.             } else if (valuePtr->type == TYPE_DOUBLE){
  785.                 valuePtr->doubleValue = -valuePtr->doubleValue;
  786.             } else {
  787.                 badType = valuePtr->type;
  788.                 goto illegalType;
  789.             } 
  790.             break;
  791.             case UNARY_PLUS:
  792.             if ((valuePtr->type != TYPE_INT)
  793.                 && (valuePtr->type != TYPE_DOUBLE)) {
  794.                 badType = valuePtr->type;
  795.                 goto illegalType;
  796.             } 
  797.             break;
  798.             case NOT:
  799.             if (valuePtr->type == TYPE_INT) {
  800.                 valuePtr->intValue = !valuePtr->intValue;
  801.             } else if (valuePtr->type == TYPE_DOUBLE) {
  802.                 /*
  803.                  * Theoretically, should be able to use
  804.                  * "!valuePtr->intValue", but apparently some
  805.                  * compilers can't handle it.
  806.                  */
  807.                 if (valuePtr->doubleValue == 0.0) {
  808.                 valuePtr->intValue = 1;
  809.                 } else {
  810.                 valuePtr->intValue = 0;
  811.                 }
  812.                 valuePtr->type = TYPE_INT;
  813.             } else {
  814.                 badType = valuePtr->type;
  815.                 goto illegalType;
  816.             }
  817.             break;
  818.             case BIT_NOT:
  819.             if (valuePtr->type == TYPE_INT) {
  820.                 valuePtr->intValue = ~valuePtr->intValue;
  821.             } else {
  822.                 badType  = valuePtr->type;
  823.                 goto illegalType;
  824.             }
  825.             break;
  826.         }
  827.         }
  828.         gotOp = 1;
  829.     } else if (infoPtr->token != VALUE) {
  830.         goto syntaxError;
  831.     }
  832.     }
  833.  
  834.     /*
  835.      * Got the first operand.  Now fetch (operator, operand) pairs.
  836.      */
  837.  
  838.     if (!gotOp) {
  839.     result = ExprLex(interp, infoPtr, &value2);
  840.     if (result != TCL_OK) {
  841.         goto done;
  842.     }
  843.     }
  844.     while (1) {
  845.     operator = infoPtr->token;
  846.     value2.pv.next = value2.pv.buffer;
  847.     if ((operator < MULT) || (operator >= UNARY_MINUS)) {
  848.         if ((operator == END) || (operator == CLOSE_PAREN)
  849.             || (operator == COMMA)) {
  850.         result = TCL_OK;
  851.         goto done;
  852.         } else {
  853.         goto syntaxError;
  854.         }
  855.     }
  856.     if (precTable[operator] <= prec) {
  857.         result = TCL_OK;
  858.         goto done;
  859.     }
  860.  
  861.     /*
  862.      * If we're doing an AND or OR and the first operand already
  863.      * determines the result, don't execute anything in the
  864.      * second operand:  just parse.  Same style for ?: pairs.
  865.      */
  866.  
  867.     if ((operator == AND) || (operator == OR) || (operator == QUESTY)) {
  868.         if (valuePtr->type == TYPE_DOUBLE) {
  869.         valuePtr->intValue = valuePtr->doubleValue != 0;
  870.         valuePtr->type = TYPE_INT;
  871.         } else if (valuePtr->type == TYPE_STRING) {
  872.         if (!iPtr->noEval) {
  873.             badType = TYPE_STRING;
  874.             goto illegalType;
  875.         }
  876.  
  877.         /*
  878.          * Must set valuePtr->intValue to avoid referencing
  879.          * uninitialized memory in the "if" below;  the atual
  880.          * value doesn't matter, since it will be ignored.
  881.          */
  882.  
  883.         valuePtr->intValue = 0;
  884.         }
  885.         if (((operator == AND) && !valuePtr->intValue)
  886.             || ((operator == OR) && valuePtr->intValue)) {
  887.         iPtr->noEval++;
  888.         result = ExprGetValue(interp, infoPtr, precTable[operator],
  889.             &value2);
  890.         iPtr->noEval--;
  891.         if (operator == OR) {
  892.             valuePtr->intValue = 1;
  893.         }
  894.         continue;
  895.         } else if (operator == QUESTY) {
  896.         /*
  897.          * Special note:  ?: operators must associate right to
  898.          * left.  To make this happen, use a precedence one lower
  899.          * than QUESTY when calling ExprGetValue recursively.
  900.          */
  901.  
  902.         if (valuePtr->intValue != 0) {
  903.             valuePtr->pv.next = valuePtr->pv.buffer;
  904.             result = ExprGetValue(interp, infoPtr,
  905.                 precTable[QUESTY] - 1, valuePtr);
  906.             if (result != TCL_OK) {
  907.             goto done;
  908.             }
  909.             if (infoPtr->token != COLON) {
  910.             goto syntaxError;
  911.             }
  912.             value2.pv.next = value2.pv.buffer;
  913.             iPtr->noEval++;
  914.             result = ExprGetValue(interp, infoPtr,
  915.                 precTable[QUESTY] - 1, &value2);
  916.             iPtr->noEval--;
  917.         } else {
  918.             iPtr->noEval++;
  919.             result = ExprGetValue(interp, infoPtr,
  920.                 precTable[QUESTY] - 1, &value2);
  921.             iPtr->noEval--;
  922.             if (result != TCL_OK) {
  923.             goto done;
  924.             }
  925.             if (infoPtr->token != COLON) {
  926.             goto syntaxError;
  927.             }
  928.             valuePtr->pv.next = valuePtr->pv.buffer;
  929.             result = ExprGetValue(interp, infoPtr,
  930.                 precTable[QUESTY] - 1, valuePtr);
  931.         }
  932.         continue;
  933.         } else {
  934.         result = ExprGetValue(interp, infoPtr, precTable[operator],
  935.             &value2);
  936.         }
  937.     } else {
  938.         result = ExprGetValue(interp, infoPtr, precTable[operator],
  939.             &value2);
  940.     }
  941.     if (result != TCL_OK) {
  942.         goto done;
  943.     }
  944.     if ((infoPtr->token < MULT) && (infoPtr->token != VALUE)
  945.         && (infoPtr->token != END) && (infoPtr->token != COMMA)
  946.         && (infoPtr->token != CLOSE_PAREN)) {
  947.         goto syntaxError;
  948.     }
  949.  
  950.     if (iPtr->noEval) {
  951.         continue;
  952.     }
  953.  
  954.     /*
  955.      * At this point we've got two values and an operator.  Check
  956.      * to make sure that the particular data types are appropriate
  957.      * for the particular operator, and perform type conversion
  958.      * if necessary.
  959.      */
  960.  
  961.     switch (operator) {
  962.  
  963.         /*
  964.          * For the operators below, no strings are allowed and
  965.          * ints get converted to floats if necessary.
  966.          */
  967.  
  968.         case MULT: case DIVIDE: case PLUS: case MINUS:
  969.         if ((valuePtr->type == TYPE_STRING)
  970.             || (value2.type == TYPE_STRING)) {
  971.             badType = TYPE_STRING;
  972.             goto illegalType;
  973.         }
  974.         if (valuePtr->type == TYPE_DOUBLE) {
  975.             if (value2.type == TYPE_INT) {
  976.             value2.doubleValue = value2.intValue;
  977.             value2.type = TYPE_DOUBLE;
  978.             }
  979.         } else if (value2.type == TYPE_DOUBLE) {
  980.             if (valuePtr->type == TYPE_INT) {
  981.             valuePtr->doubleValue = valuePtr->intValue;
  982.             valuePtr->type = TYPE_DOUBLE;
  983.             }
  984.         }
  985.         break;
  986.  
  987.         /*
  988.          * For the operators below, only integers are allowed.
  989.          */
  990.  
  991.         case MOD: case LEFT_SHIFT: case RIGHT_SHIFT:
  992.         case BIT_AND: case BIT_XOR: case BIT_OR:
  993.          if (valuePtr->type != TYPE_INT) {
  994.              badType = valuePtr->type;
  995.              goto illegalType;
  996.          } else if (value2.type != TYPE_INT) {
  997.              badType = value2.type;
  998.              goto illegalType;
  999.          }
  1000.          break;
  1001.  
  1002.         /*
  1003.          * For the operators below, any type is allowed but the
  1004.          * two operands must have the same type.  Convert integers
  1005.          * to floats and either to strings, if necessary.
  1006.          */
  1007.  
  1008.         case LESS: case GREATER: case LEQ: case GEQ:
  1009.         case EQUAL: case NEQ:
  1010.         if (valuePtr->type == TYPE_STRING) {
  1011.             if (value2.type != TYPE_STRING) {
  1012.             ExprMakeString(interp, &value2);
  1013.             }
  1014.         } else if (value2.type == TYPE_STRING) {
  1015.             if (valuePtr->type != TYPE_STRING) {
  1016.             ExprMakeString(interp, valuePtr);
  1017.             }
  1018.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1019.             if (value2.type == TYPE_INT) {
  1020.             value2.doubleValue = value2.intValue;
  1021.             value2.type = TYPE_DOUBLE;
  1022.             }
  1023.         } else if (value2.type == TYPE_DOUBLE) {
  1024.              if (valuePtr->type == TYPE_INT) {
  1025.             valuePtr->doubleValue = valuePtr->intValue;
  1026.             valuePtr->type = TYPE_DOUBLE;
  1027.             }
  1028.         }
  1029.         break;
  1030.  
  1031.         /*
  1032.          * For the operators below, no strings are allowed, but
  1033.          * no int->double conversions are performed.
  1034.          */
  1035.  
  1036.         case AND: case OR:
  1037.         if (valuePtr->type == TYPE_STRING) {
  1038.             badType = valuePtr->type;
  1039.             goto illegalType;
  1040.         }
  1041.         if (value2.type == TYPE_STRING) {
  1042.             badType = value2.type;
  1043.             goto illegalType;
  1044.         }
  1045.         break;
  1046.  
  1047.         /*
  1048.          * For the operators below, type and conversions are
  1049.          * irrelevant:  they're handled elsewhere.
  1050.          */
  1051.  
  1052.         case QUESTY: case COLON:
  1053.         break;
  1054.  
  1055.         /*
  1056.          * Any other operator is an error.
  1057.          */
  1058.  
  1059.         default:
  1060.         interp->result = "unknown operator in expression";
  1061.         result = TCL_ERROR;
  1062.         goto done;
  1063.     }
  1064.  
  1065.     /*
  1066.      * Carry out the function of the specified operator.
  1067.      */
  1068.  
  1069.     switch (operator) {
  1070.         case MULT:
  1071.         if (valuePtr->type == TYPE_INT) {
  1072.             valuePtr->intValue = valuePtr->intValue * value2.intValue;
  1073.         } else {
  1074.             valuePtr->doubleValue *= value2.doubleValue;
  1075.         }
  1076.         break;
  1077.         case DIVIDE:
  1078.         case MOD:
  1079.         if (valuePtr->type == TYPE_INT) {
  1080.             long divisor, quot, rem;
  1081.             int negative;
  1082.  
  1083.             if (value2.intValue == 0) {
  1084.             divideByZero:
  1085.             interp->result = "divide by zero";
  1086.             Tcl_SetErrorCode(interp, "ARITH", "DIVZERO",
  1087.                 interp->result, (char *) NULL);
  1088.             result = TCL_ERROR;
  1089.             goto done;
  1090.             }
  1091.  
  1092.             /*
  1093.              * The code below is tricky because C doesn't guarantee
  1094.              * much about the properties of the quotient or
  1095.              * remainder, but Tcl does:  the remainder always has
  1096.              * the same sign as the divisor and a smaller absolute
  1097.              * value.
  1098.              */
  1099.  
  1100.             divisor = value2.intValue;
  1101.             negative = 0;
  1102.             if (divisor < 0) {
  1103.             divisor = -divisor;
  1104.             valuePtr->intValue = -valuePtr->intValue;
  1105.             negative = 1;
  1106.             }
  1107.             quot = valuePtr->intValue / divisor;
  1108.             rem = valuePtr->intValue % divisor;
  1109.             if (rem < 0) {
  1110.             rem += divisor;
  1111.             quot -= 1;
  1112.             }
  1113.             if (negative) {
  1114.             rem = -rem;
  1115.             }
  1116.             valuePtr->intValue = (operator == DIVIDE) ? quot : rem;
  1117.         } else {
  1118.             if (value2.doubleValue == 0.0) {
  1119.             goto divideByZero;
  1120.             }
  1121.             valuePtr->doubleValue /= value2.doubleValue;
  1122.         }
  1123.         break;
  1124.         case PLUS:
  1125.         if (valuePtr->type == TYPE_INT) {
  1126.             valuePtr->intValue = valuePtr->intValue + value2.intValue;
  1127.         } else {
  1128.             valuePtr->doubleValue += value2.doubleValue;
  1129.         }
  1130.         break;
  1131.         case MINUS:
  1132.         if (valuePtr->type == TYPE_INT) {
  1133.             valuePtr->intValue = valuePtr->intValue - value2.intValue;
  1134.         } else {
  1135.             valuePtr->doubleValue -= value2.doubleValue;
  1136.         }
  1137.         break;
  1138.         case LEFT_SHIFT:
  1139.         valuePtr->intValue <<= value2.intValue;
  1140.         break;
  1141.         case RIGHT_SHIFT:
  1142.         /*
  1143.          * The following code is a bit tricky:  it ensures that
  1144.          * right shifts propagate the sign bit even on machines
  1145.          * where ">>" won't do it by default.
  1146.          */
  1147.  
  1148.         if (valuePtr->intValue < 0) {
  1149.             valuePtr->intValue =
  1150.                 ~((~valuePtr->intValue) >> value2.intValue);
  1151.         } else {
  1152.             valuePtr->intValue >>= value2.intValue;
  1153.         }
  1154.         break;
  1155.         case LESS:
  1156.         if (valuePtr->type == TYPE_INT) {
  1157.             valuePtr->intValue =
  1158.             valuePtr->intValue < value2.intValue;
  1159.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1160.             valuePtr->intValue =
  1161.             valuePtr->doubleValue < value2.doubleValue;
  1162.         } else {
  1163.             valuePtr->intValue =
  1164.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) < 0;
  1165.         }
  1166.         valuePtr->type = TYPE_INT;
  1167.         break;
  1168.         case GREATER:
  1169.         if (valuePtr->type == TYPE_INT) {
  1170.             valuePtr->intValue =
  1171.             valuePtr->intValue > value2.intValue;
  1172.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1173.             valuePtr->intValue =
  1174.             valuePtr->doubleValue > value2.doubleValue;
  1175.         } else {
  1176.             valuePtr->intValue =
  1177.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) > 0;
  1178.         }
  1179.         valuePtr->type = TYPE_INT;
  1180.         break;
  1181.         case LEQ:
  1182.         if (valuePtr->type == TYPE_INT) {
  1183.             valuePtr->intValue =
  1184.             valuePtr->intValue <= value2.intValue;
  1185.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1186.             valuePtr->intValue =
  1187.             valuePtr->doubleValue <= value2.doubleValue;
  1188.         } else {
  1189.             valuePtr->intValue =
  1190.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) <= 0;
  1191.         }
  1192.         valuePtr->type = TYPE_INT;
  1193.         break;
  1194.         case GEQ:
  1195.         if (valuePtr->type == TYPE_INT) {
  1196.             valuePtr->intValue =
  1197.             valuePtr->intValue >= value2.intValue;
  1198.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1199.             valuePtr->intValue =
  1200.             valuePtr->doubleValue >= value2.doubleValue;
  1201.         } else {
  1202.             valuePtr->intValue =
  1203.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) >= 0;
  1204.         }
  1205.         valuePtr->type = TYPE_INT;
  1206.         break;
  1207.         case EQUAL:
  1208.         if (valuePtr->type == TYPE_INT) {
  1209.             valuePtr->intValue =
  1210.             valuePtr->intValue == value2.intValue;
  1211.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1212.             valuePtr->intValue =
  1213.             valuePtr->doubleValue == value2.doubleValue;
  1214.         } else {
  1215.             valuePtr->intValue =
  1216.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) == 0;
  1217.         }
  1218.         valuePtr->type = TYPE_INT;
  1219.         break;
  1220.         case NEQ:
  1221.         if (valuePtr->type == TYPE_INT) {
  1222.             valuePtr->intValue =
  1223.             valuePtr->intValue != value2.intValue;
  1224.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1225.             valuePtr->intValue =
  1226.             valuePtr->doubleValue != value2.doubleValue;
  1227.         } else {
  1228.             valuePtr->intValue =
  1229.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) != 0;
  1230.         }
  1231.         valuePtr->type = TYPE_INT;
  1232.         break;
  1233.         case BIT_AND:
  1234.         valuePtr->intValue &= value2.intValue;
  1235.         break;
  1236.         case BIT_XOR:
  1237.         valuePtr->intValue ^= value2.intValue;
  1238.         break;
  1239.         case BIT_OR:
  1240.         valuePtr->intValue |= value2.intValue;
  1241.         break;
  1242.  
  1243.         /*
  1244.          * For AND and OR, we know that the first value has already
  1245.          * been converted to an integer.  Thus we need only consider
  1246.          * the possibility of int vs. double for the second value.
  1247.          */
  1248.  
  1249.         case AND:
  1250.         if (value2.type == TYPE_DOUBLE) {
  1251.             value2.intValue = value2.doubleValue != 0;
  1252.             value2.type = TYPE_INT;
  1253.         }
  1254.         valuePtr->intValue = valuePtr->intValue && value2.intValue;
  1255.         break;
  1256.         case OR:
  1257.         if (value2.type == TYPE_DOUBLE) {
  1258.             value2.intValue = value2.doubleValue != 0;
  1259.             value2.type = TYPE_INT;
  1260.         }
  1261.         valuePtr->intValue = valuePtr->intValue || value2.intValue;
  1262.         break;
  1263.  
  1264.         case COLON:
  1265.         interp->result = "can't have : operator without ? first";
  1266.         result = TCL_ERROR;
  1267.         goto done;
  1268.     }
  1269.     }
  1270.  
  1271.     done:
  1272.     if (value2.pv.buffer != value2.staticSpace) {
  1273.     ckfree(value2.pv.buffer);
  1274.     }
  1275.     return result;
  1276.  
  1277.     syntaxError:
  1278.     Tcl_AppendResult(interp, "syntax error in expression \"",
  1279.         infoPtr->originalExpr, "\"", (char *) NULL);
  1280.     result = TCL_ERROR;
  1281.     goto done;
  1282.  
  1283.     illegalType:
  1284.     Tcl_AppendResult(interp, "can't use ", (badType == TYPE_DOUBLE) ?
  1285.         "floating-point value" : "non-numeric string",
  1286.         " as operand of \"", operatorStrings[operator], "\"",
  1287.         (char *) NULL);
  1288.     result = TCL_ERROR;
  1289.     goto done;
  1290. }
  1291.  
  1292. /*
  1293.  *--------------------------------------------------------------
  1294.  *
  1295.  * ExprMakeString --
  1296.  *
  1297.  *    Convert a value from int or double representation to
  1298.  *    a string.
  1299.  *
  1300.  * Results:
  1301.  *    The information at *valuePtr gets converted to string
  1302.  *    format, if it wasn't that way already.
  1303.  *
  1304.  * Side effects:
  1305.  *    None.
  1306.  *
  1307.  *--------------------------------------------------------------
  1308.  */
  1309.  
  1310. static void
  1311. ExprMakeString(interp, valuePtr)
  1312.     Tcl_Interp *interp;            /* Interpreter to use for precision
  1313.                      * information. */
  1314.     register Value *valuePtr;        /* Value to be converted. */
  1315. {
  1316.     int shortfall;
  1317.  
  1318.     shortfall = 150 - (valuePtr->pv.end - valuePtr->pv.buffer);
  1319.     if (shortfall > 0) {
  1320.     (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall);
  1321.     }
  1322.     if (valuePtr->type == TYPE_INT) {
  1323.     sprintf(valuePtr->pv.buffer, "%ld", valuePtr->intValue);
  1324.     } else if (valuePtr->type == TYPE_DOUBLE) {
  1325.     Tcl_PrintDouble(interp, valuePtr->doubleValue, valuePtr->pv.buffer);
  1326.     }
  1327.     valuePtr->type = TYPE_STRING;
  1328. }
  1329.  
  1330. /*
  1331.  *--------------------------------------------------------------
  1332.  *
  1333.  * ExprTopLevel --
  1334.  *
  1335.  *    This procedure provides top-level functionality shared by
  1336.  *    procedures like Tcl_ExprInt, Tcl_ExprDouble, etc.
  1337.  *
  1338.  * Results:
  1339.  *    The result is a standard Tcl return value.  If an error
  1340.  *    occurs then an error message is left in interp->result.
  1341.  *    The value of the expression is returned in *valuePtr, in
  1342.  *    whatever form it ends up in (could be string or integer
  1343.  *    or double).  Caller may need to convert result.  Caller
  1344.  *    is also responsible for freeing string memory in *valuePtr,
  1345.  *    if any was allocated.
  1346.  *
  1347.  * Side effects:
  1348.  *    None.
  1349.  *
  1350.  *--------------------------------------------------------------
  1351.  */
  1352.  
  1353. static int
  1354. ExprTopLevel(interp, string, valuePtr)
  1355.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1356.                      * expression. */
  1357.     char *string;            /* Expression to evaluate. */
  1358.     Value *valuePtr;            /* Where to store result.  Should
  1359.                      * not be initialized by caller. */
  1360. {
  1361.     ExprInfo info;
  1362.     int result;
  1363.  
  1364.     /*
  1365.      * Create the math functions the first time an expression is
  1366.      * evaluated.
  1367.      */
  1368.  
  1369.     if (!(((Interp *) interp)->flags & EXPR_INITIALIZED)) {
  1370.     BuiltinFunc *funcPtr;
  1371.  
  1372.     ((Interp *) interp)->flags |= EXPR_INITIALIZED;
  1373.     for (funcPtr = funcTable; funcPtr->name != NULL;
  1374.         funcPtr++) {
  1375.         Tcl_CreateMathFunc(interp, funcPtr->name, funcPtr->numArgs,
  1376.             funcPtr->argTypes, funcPtr->proc, funcPtr->clientData);
  1377.     }
  1378.     }
  1379.  
  1380.     info.originalExpr = string;
  1381.     info.expr = string;
  1382.     valuePtr->pv.buffer = valuePtr->pv.next = valuePtr->staticSpace;
  1383.     valuePtr->pv.end = valuePtr->pv.buffer + STATIC_STRING_SPACE - 1;
  1384.     valuePtr->pv.expandProc = TclExpandParseValue;
  1385.     valuePtr->pv.clientData = (ClientData) NULL;
  1386.  
  1387.     result = ExprGetValue(interp, &info, -1, valuePtr);
  1388.     if (result != TCL_OK) {
  1389.     return result;
  1390.     }
  1391.     if (info.token != END) {
  1392.     Tcl_AppendResult(interp, "syntax error in expression \"",
  1393.         string, "\"", (char *) NULL);
  1394.     return TCL_ERROR;
  1395.     }
  1396.     if ((valuePtr->type == TYPE_DOUBLE) && (IS_NAN(valuePtr->doubleValue)
  1397.         || IS_INF(valuePtr->doubleValue))) {
  1398.     /*
  1399.      * IEEE floating-point error.
  1400.      */
  1401.  
  1402.     TclExprFloatError(interp, valuePtr->doubleValue);
  1403.     return TCL_ERROR;
  1404.     }
  1405.     return TCL_OK;
  1406. }
  1407.  
  1408. /*
  1409.  *--------------------------------------------------------------
  1410.  *
  1411.  * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
  1412.  *
  1413.  *    Procedures to evaluate an expression and return its value
  1414.  *    in a particular form.
  1415.  *
  1416.  * Results:
  1417.  *    Each of the procedures below returns a standard Tcl result.
  1418.  *    If an error occurs then an error message is left in
  1419.  *    interp->result.  Otherwise the value of the expression,
  1420.  *    in the appropriate form, is stored at *resultPtr.  If
  1421.  *    the expression had a result that was incompatible with the
  1422.  *    desired form then an error is returned.
  1423.  *
  1424.  * Side effects:
  1425.  *    None.
  1426.  *
  1427.  *--------------------------------------------------------------
  1428.  */
  1429.  
  1430. int
  1431. Tcl_ExprLong(interp, string, ptr)
  1432.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1433.                      * expression. */
  1434.     char *string;            /* Expression to evaluate. */
  1435.     long *ptr;                /* Where to store result. */
  1436. {
  1437.     Value value;
  1438.     int result;
  1439.  
  1440.     result = ExprTopLevel(interp, string, &value);
  1441.     if (result == TCL_OK) {
  1442.     if (value.type == TYPE_INT) {
  1443.         *ptr = value.intValue;
  1444.     } else if (value.type == TYPE_DOUBLE) {
  1445.         *ptr = (long) value.doubleValue;
  1446.     } else {
  1447.         interp->result = "expression didn't have numeric value";
  1448.         result = TCL_ERROR;
  1449.     }
  1450.     }
  1451.     if (value.pv.buffer != value.staticSpace) {
  1452.     ckfree(value.pv.buffer);
  1453.     }
  1454.     return result;
  1455. }
  1456.  
  1457. int
  1458. Tcl_ExprDouble(interp, string, ptr)
  1459.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1460.                      * expression. */
  1461.     char *string;            /* Expression to evaluate. */
  1462.     double *ptr;            /* Where to store result. */
  1463. {
  1464.     Value value;
  1465.     int result;
  1466.  
  1467.     result = ExprTopLevel(interp, string, &value);
  1468.     if (result == TCL_OK) {
  1469.     if (value.type == TYPE_INT) {
  1470.         *ptr = value.intValue;
  1471.     } else if (value.type == TYPE_DOUBLE) {
  1472.         *ptr = value.doubleValue;
  1473.     } else {
  1474.         interp->result = "expression didn't have numeric value";
  1475.         result = TCL_ERROR;
  1476.     }
  1477.     }
  1478.     if (value.pv.buffer != value.staticSpace) {
  1479.     ckfree(value.pv.buffer);
  1480.     }
  1481.     return result;
  1482. }
  1483.  
  1484. int
  1485. Tcl_ExprBoolean(interp, string, ptr)
  1486.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1487.                      * expression. */
  1488.     char *string;            /* Expression to evaluate. */
  1489.     int *ptr;                /* Where to store 0/1 result. */
  1490. {
  1491.     Value value;
  1492.     int result;
  1493.  
  1494.     result = ExprTopLevel(interp, string, &value);
  1495.     if (result == TCL_OK) {
  1496.     if (value.type == TYPE_INT) {
  1497.         *ptr = value.intValue != 0;
  1498.     } else if (value.type == TYPE_DOUBLE) {
  1499.         *ptr = value.doubleValue != 0.0;
  1500.     } else {
  1501.         result = Tcl_GetBoolean(interp, value.pv.buffer, ptr);
  1502.     }
  1503.     }
  1504.     if (value.pv.buffer != value.staticSpace) {
  1505.     ckfree(value.pv.buffer);
  1506.     }
  1507.     return result;
  1508. }
  1509.  
  1510. /*
  1511.  *--------------------------------------------------------------
  1512.  *
  1513.  * Tcl_ExprString --
  1514.  *
  1515.  *    Evaluate an expression and return its value in string form.
  1516.  *
  1517.  * Results:
  1518.  *    A standard Tcl result.  If the result is TCL_OK, then the
  1519.  *    interpreter's result is set to the string value of the
  1520.  *    expression.  If the result is TCL_OK, then interp->result
  1521.  *    contains an error message.
  1522.  *
  1523.  * Side effects:
  1524.  *    None.
  1525.  *
  1526.  *--------------------------------------------------------------
  1527.  */
  1528.  
  1529. int
  1530. Tcl_ExprString(interp, string)
  1531.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1532.                      * expression. */
  1533.     char *string;            /* Expression to evaluate. */
  1534. {
  1535.     Value value;
  1536.     int result;
  1537.  
  1538.     result = ExprTopLevel(interp, string, &value);
  1539.     if (result == TCL_OK) {
  1540.     if (value.type == TYPE_INT) {
  1541.         sprintf(interp->result, "%ld", value.intValue);
  1542.     } else if (value.type == TYPE_DOUBLE) {
  1543.         Tcl_PrintDouble(interp, value.doubleValue, interp->result);
  1544.     } else {
  1545.         if (value.pv.buffer != value.staticSpace) {
  1546.         interp->result = value.pv.buffer;
  1547.         interp->freeProc = TCL_DYNAMIC;
  1548.         value.pv.buffer = value.staticSpace;
  1549.         } else {
  1550.         Tcl_SetResult(interp, value.pv.buffer, TCL_VOLATILE);
  1551.         }
  1552.     }
  1553.     }
  1554.     if (value.pv.buffer != value.staticSpace) {
  1555.     ckfree(value.pv.buffer);
  1556.     }
  1557.     return result;
  1558. }
  1559.  
  1560. /*
  1561.  *----------------------------------------------------------------------
  1562.  *
  1563.  * Tcl_CreateMathFunc --
  1564.  *
  1565.  *    Creates a new math function for expressions in a given
  1566.  *    interpreter.
  1567.  *
  1568.  * Results:
  1569.  *    None.
  1570.  *
  1571.  * Side effects:
  1572.  *    The function defined by "name" is created;  if such a function
  1573.  *    already existed then its definition is overriden.
  1574.  *
  1575.  *----------------------------------------------------------------------
  1576.  */
  1577.  
  1578. void
  1579. Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData)
  1580.     Tcl_Interp *interp;            /* Interpreter in which function is
  1581.                      * to be available. */
  1582.     char *name;                /* Name of function (e.g. "sin"). */
  1583.     int numArgs;            /* Nnumber of arguments required by
  1584.                      * function. */
  1585.     Tcl_ValueType *argTypes;        /* Array of types acceptable for
  1586.                      * each argument. */
  1587.     Tcl_MathProc *proc;            /* Procedure that implements the
  1588.                      * math function. */
  1589.     ClientData clientData;        /* Additional value to pass to the
  1590.                      * function. */
  1591. {
  1592.     Interp *iPtr = (Interp *) interp;
  1593.     Tcl_HashEntry *hPtr;
  1594.     MathFunc *mathFuncPtr;
  1595.     int new, i;
  1596.  
  1597.     hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new);
  1598.     if (new) {
  1599.     Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc)));
  1600.     }
  1601.     mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
  1602.     if (numArgs > MAX_MATH_ARGS) {
  1603.     numArgs = MAX_MATH_ARGS;
  1604.     }
  1605.     mathFuncPtr->numArgs = numArgs;
  1606.     for (i = 0; i < numArgs; i++) {
  1607.     mathFuncPtr->argTypes[i] = argTypes[i];
  1608.     }
  1609.     mathFuncPtr->proc = proc;
  1610.     mathFuncPtr->clientData = clientData;
  1611. }
  1612.  
  1613. /*
  1614.  *----------------------------------------------------------------------
  1615.  *
  1616.  * ExprMathFunc --
  1617.  *
  1618.  *    This procedure is invoked to parse a math function from an
  1619.  *    expression string, carry out the function, and return the
  1620.  *    value computed.
  1621.  *
  1622.  * Results:
  1623.  *    TCL_OK is returned if all went well and the function's value
  1624.  *    was computed successfully.  If an error occurred, TCL_ERROR
  1625.  *    is returned and an error message is left in interp->result.
  1626.  *    After a successful return infoPtr has been updated to refer
  1627.  *    to the character just after the function call, the token is
  1628.  *    set to VALUE, and the value is stored in valuePtr.
  1629.  *
  1630.  * Side effects:
  1631.  *    Embedded commands could have arbitrary side-effects.
  1632.  *
  1633.  *----------------------------------------------------------------------
  1634.  */
  1635.  
  1636. static int
  1637. ExprMathFunc(interp, infoPtr, valuePtr)
  1638.     Tcl_Interp *interp;            /* Interpreter to use for error
  1639.                      * reporting. */
  1640.     register ExprInfo *infoPtr;        /* Describes the state of the parse.
  1641.                      * infoPtr->expr must point to the
  1642.                      * first character of the function's
  1643.                      * name. */
  1644.     register Value *valuePtr;        /* Where to store value, if that is
  1645.                      * what's parsed from string.  Caller
  1646.                      * must have initialized pv field
  1647.                      * correctly. */
  1648. {
  1649.     Interp *iPtr = (Interp *) interp;
  1650.     MathFunc *mathFuncPtr;        /* Info about math function. */
  1651.     Tcl_Value args[MAX_MATH_ARGS];    /* Arguments for function call. */
  1652.     Tcl_Value funcResult;        /* Result of function call. */
  1653.     Tcl_HashEntry *hPtr;
  1654.     char *p, *funcName, savedChar;
  1655.     int i, result;
  1656.  
  1657.     /*
  1658.      * Find the end of the math function's name and lookup the MathFunc
  1659.      * record for the function.
  1660.      */
  1661.  
  1662.     p = funcName = infoPtr->expr;
  1663.     while (isalnum(UCHAR(*p)) || (*p == '_')) {
  1664.     p++;
  1665.     }
  1666.     infoPtr->expr = p;
  1667.     result = ExprLex(interp, infoPtr, valuePtr);
  1668.     if (result != TCL_OK) {
  1669.     return TCL_ERROR;
  1670.     }
  1671.     if (infoPtr->token != OPEN_PAREN) {
  1672.     goto syntaxError;
  1673.     }
  1674.     savedChar = *p;
  1675.     *p = 0;
  1676.     hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
  1677.     if (hPtr == NULL) {
  1678.     Tcl_AppendResult(interp, "unknown math function \"", funcName,
  1679.         "\"", (char *) NULL);
  1680.     *p = savedChar;
  1681.     return TCL_ERROR;
  1682.     }
  1683.     *p = savedChar;
  1684.     mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
  1685.  
  1686.     /*
  1687.      * Scan off the arguments for the function, if there are any.
  1688.      */
  1689.  
  1690.     if (mathFuncPtr->numArgs == 0) {
  1691.     result = ExprLex(interp, infoPtr, valuePtr);
  1692.     if ((result != TCL_OK) || (infoPtr->token != CLOSE_PAREN)) {
  1693.         goto syntaxError;
  1694.     }
  1695.     } else {
  1696.     for (i = 0; ; i++) {
  1697.         valuePtr->pv.next = valuePtr->pv.buffer;
  1698.         result = ExprGetValue(interp, infoPtr, -1, valuePtr);
  1699.         if (result != TCL_OK) {
  1700.         return result;
  1701.         }
  1702.         if (valuePtr->type == TYPE_STRING) {
  1703.         interp->result =
  1704.             "argument to math function didn't have numeric value";
  1705.         return TCL_ERROR;
  1706.         }
  1707.     
  1708.         /*
  1709.          * Copy the value to the argument record, converting it if
  1710.          * necessary.
  1711.          */
  1712.     
  1713.         if (valuePtr->type == TYPE_INT) {
  1714.         if (mathFuncPtr->argTypes[i] == TCL_DOUBLE) {
  1715.             args[i].type = TCL_DOUBLE;
  1716.             args[i].doubleValue = valuePtr->intValue;
  1717.         } else {
  1718.             args[i].type = TCL_INT;
  1719.             args[i].intValue = valuePtr->intValue;
  1720.         }
  1721.         } else {
  1722.         if (mathFuncPtr->argTypes[i] == TCL_INT) {
  1723.             args[i].type = TCL_INT;
  1724.             args[i].intValue = (long) valuePtr->doubleValue;
  1725.         } else {
  1726.             args[i].type = TCL_DOUBLE;
  1727.             args[i].doubleValue = valuePtr->doubleValue;
  1728.         }
  1729.         }
  1730.     
  1731.         /*
  1732.          * Check for a comma separator between arguments or a close-paren
  1733.          * to end the argument list.
  1734.          */
  1735.     
  1736.         if (i == (mathFuncPtr->numArgs-1)) {
  1737.         if (infoPtr->token == CLOSE_PAREN) {
  1738.             break;
  1739.         }
  1740.         if (infoPtr->token == COMMA) {
  1741.             interp->result = "too many arguments for math function";
  1742.             return TCL_ERROR;
  1743.         } else {
  1744.             goto syntaxError;
  1745.         }
  1746.         }
  1747.         if (infoPtr->token != COMMA) {
  1748.         if (infoPtr->token == CLOSE_PAREN) {
  1749.             interp->result = "too few arguments for math function";
  1750.             return TCL_ERROR;
  1751.         } else {
  1752.             goto syntaxError;
  1753.         }
  1754.         }
  1755.     }
  1756.     }
  1757.     if (iPtr->noEval) {
  1758.     valuePtr->type = TYPE_INT;
  1759.     valuePtr->intValue = 0;
  1760.     infoPtr->token = VALUE;
  1761.     return TCL_OK;
  1762.     }
  1763.  
  1764.     /*
  1765.      * Invoke the function and copy its result back into valuePtr.
  1766.      */
  1767.  
  1768.     tcl_MathInProgress++;
  1769.     result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args,
  1770.         &funcResult);
  1771.     tcl_MathInProgress--;
  1772.     if (result != TCL_OK) {
  1773.     return result;
  1774.     }
  1775.     if (funcResult.type == TCL_INT) {
  1776.     valuePtr->type = TYPE_INT;
  1777.     valuePtr->intValue = funcResult.intValue;
  1778.     } else {
  1779.     valuePtr->type = TYPE_DOUBLE;
  1780.     valuePtr->doubleValue = funcResult.doubleValue;
  1781.     }
  1782.     infoPtr->token = VALUE;
  1783.     return TCL_OK;
  1784.  
  1785.     syntaxError:
  1786.     Tcl_AppendResult(interp, "syntax error in expression \"",
  1787.         infoPtr->originalExpr, "\"", (char *) NULL);
  1788.     return TCL_ERROR;
  1789. }
  1790.  
  1791. /*
  1792.  *----------------------------------------------------------------------
  1793.  *
  1794.  * TclExprFloatError --
  1795.  *
  1796.  *    This procedure is called when an error occurs during a
  1797.  *    floating-point operation.  It reads errno and sets
  1798.  *    interp->result accordingly.
  1799.  *
  1800.  * Results:
  1801.  *    Interp->result is set to hold an error message.
  1802.  *
  1803.  * Side effects:
  1804.  *    None.
  1805.  *
  1806.  *----------------------------------------------------------------------
  1807.  */
  1808.  
  1809. void
  1810. TclExprFloatError(interp, value)
  1811.     Tcl_Interp *interp;        /* Where to store error message. */
  1812.     double value;        /* Value returned after error;  used to
  1813.                  * distinguish underflows from overflows. */
  1814. {
  1815.     char buf[20];
  1816.  
  1817.     if ((errno == EDOM) || (value != value)) {
  1818.     interp->result = "domain error: argument not in valid range";
  1819.     Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", interp->result,
  1820.         (char *) NULL);
  1821.     } else if ((errno == ERANGE) || IS_INF(value)) {
  1822.     if (value == 0.0) {
  1823.         interp->result = "floating-point value too small to represent";
  1824.         Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", interp->result,
  1825.             (char *) NULL);
  1826.     } else {
  1827.         interp->result = "floating-point value too large to represent";
  1828.         Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", interp->result,
  1829.             (char *) NULL);
  1830.     }
  1831.     } else {
  1832.     sprintf(buf, "%d", errno);
  1833.     Tcl_AppendResult(interp, "unknown floating-point error, ",
  1834.         "errno = ", buf, (char *) NULL);
  1835.     Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", interp->result,
  1836.         (char *) NULL);
  1837.     }
  1838. }
  1839.  
  1840. /*
  1841.  *----------------------------------------------------------------------
  1842.  *
  1843.  * Math Functions --
  1844.  *
  1845.  *    This page contains the procedures that implement all of the
  1846.  *    built-in math functions for expressions.
  1847.  *
  1848.  * Results:
  1849.  *    Each procedure returns TCL_OK if it succeeds and places result
  1850.  *    information at *resultPtr.  If it fails it returns TCL_ERROR
  1851.  *    and leaves an error message in interp->result.
  1852.  *
  1853.  * Side effects:
  1854.  *    None.
  1855.  *
  1856.  *----------------------------------------------------------------------
  1857.  */
  1858.  
  1859. static int
  1860. ExprUnaryFunc(clientData, interp, args, resultPtr)
  1861.     ClientData clientData;        /* Contains address of procedure that
  1862.                      * takes one double argument and
  1863.                      * returns a double result. */
  1864.     Tcl_Interp *interp;
  1865.     Tcl_Value *args;
  1866.     Tcl_Value *resultPtr;
  1867. {
  1868.     double (*func) _ANSI_ARGS_((double)) = (double (*)_ANSI_ARGS_((double))) clientData;
  1869.  
  1870.     errno = 0;
  1871.     resultPtr->type = TCL_DOUBLE;
  1872.     resultPtr->doubleValue = (*func)(args[0].doubleValue);
  1873.     if (errno != 0) {
  1874.     TclExprFloatError(interp, resultPtr->doubleValue);
  1875.     return TCL_ERROR;
  1876.     }
  1877.     return TCL_OK;
  1878. }
  1879.  
  1880. static int
  1881. ExprBinaryFunc(clientData, interp, args, resultPtr)
  1882.     ClientData clientData;        /* Contains address of procedure that
  1883.                      * takes two double arguments and
  1884.                      * returns a double result. */
  1885.     Tcl_Interp *interp;
  1886.     Tcl_Value *args;
  1887.     Tcl_Value *resultPtr;
  1888. {
  1889.     double (*func) _ANSI_ARGS_((double, double))
  1890.     = (double (*)_ANSI_ARGS_((double, double))) clientData;
  1891.  
  1892.     errno = 0;
  1893.     resultPtr->type = TCL_DOUBLE;
  1894.     resultPtr->doubleValue = (*func)(args[0].doubleValue, args[1].doubleValue);
  1895.     if (errno != 0) {
  1896.     TclExprFloatError(interp, resultPtr->doubleValue);
  1897.     return TCL_ERROR;
  1898.     }
  1899.     return TCL_OK;
  1900. }
  1901.  
  1902.     /* ARGSUSED */
  1903. static int
  1904. ExprAbsFunc(clientData, interp, args, resultPtr)
  1905.     ClientData clientData;
  1906.     Tcl_Interp *interp;
  1907.     Tcl_Value *args;
  1908.     Tcl_Value *resultPtr;
  1909. {
  1910.     resultPtr->type = TCL_DOUBLE;
  1911.     if (args[0].type == TCL_DOUBLE) {
  1912.     resultPtr->type = TCL_DOUBLE;
  1913.     if (args[0].doubleValue < 0) {
  1914.         resultPtr->doubleValue = -args[0].doubleValue;
  1915.     } else {
  1916.         resultPtr->doubleValue = args[0].doubleValue;
  1917.     }
  1918.     } else {
  1919.     resultPtr->type = TCL_INT;
  1920.     if (args[0].intValue < 0) {
  1921.         resultPtr->intValue = -args[0].intValue;
  1922.         if (resultPtr->intValue < 0) {
  1923.         interp->result = "integer value too large to represent";
  1924.         Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", interp->result,
  1925.             (char *) NULL);
  1926.         return TCL_ERROR;
  1927.         }
  1928.     } else {
  1929.         resultPtr->intValue = args[0].intValue;
  1930.     }
  1931.     }
  1932.     return TCL_OK;
  1933. }
  1934.  
  1935.     /* ARGSUSED */
  1936. static int
  1937. ExprDoubleFunc(clientData, interp, args, resultPtr)
  1938.     ClientData clientData;
  1939.     Tcl_Interp *interp;
  1940.     Tcl_Value *args;
  1941.     Tcl_Value *resultPtr;
  1942. {
  1943.     resultPtr->type = TCL_DOUBLE;
  1944.     if (args[0].type == TCL_DOUBLE) {
  1945.     resultPtr->doubleValue = args[0].doubleValue;
  1946.     } else {
  1947.     resultPtr->doubleValue = args[0].intValue;
  1948.     }
  1949.     return TCL_OK;
  1950. }
  1951.  
  1952.     /* ARGSUSED */
  1953. static int
  1954. ExprIntFunc(clientData, interp, args, resultPtr)
  1955.     ClientData clientData;
  1956.     Tcl_Interp *interp;
  1957.     Tcl_Value *args;
  1958.     Tcl_Value *resultPtr;
  1959. {
  1960.     resultPtr->type = TCL_INT;
  1961.     if (args[0].type == TCL_INT) {
  1962.     resultPtr->intValue = args[0].intValue;
  1963.     } else {
  1964.     if (args[0].doubleValue < 0) {
  1965.         if (args[0].doubleValue < (double) (long) LONG_MIN) {
  1966.         tooLarge:
  1967.         interp->result = "integer value too large to represent";
  1968.         Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
  1969.             interp->result, (char *) NULL);
  1970.         return TCL_ERROR;
  1971.         }
  1972.     } else {
  1973.         if (args[0].doubleValue > (double) LONG_MAX) {
  1974.         goto tooLarge;
  1975.         }
  1976.     }
  1977.     resultPtr->intValue = (long) args[0].doubleValue;
  1978.     }
  1979.     return TCL_OK;
  1980. }
  1981.  
  1982.     /* ARGSUSED */
  1983. static int
  1984. ExprRoundFunc(clientData, interp, args, resultPtr)
  1985.     ClientData clientData;
  1986.     Tcl_Interp *interp;
  1987.     Tcl_Value *args;
  1988.     Tcl_Value *resultPtr;
  1989. {
  1990.     resultPtr->type = TCL_INT;
  1991.     if (args[0].type == TCL_INT) {
  1992.     resultPtr->intValue = args[0].intValue;
  1993.     } else {
  1994.     if (args[0].doubleValue < 0) {
  1995.         if (args[0].doubleValue <= (((double) (long) LONG_MIN) - 0.5)) {
  1996.         tooLarge:
  1997.         interp->result = "integer value too large to represent";
  1998.         Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
  1999.             interp->result, (char *) NULL);
  2000.         return TCL_ERROR;
  2001.         }
  2002.         resultPtr->intValue = (long) (args[0].doubleValue - 0.5);
  2003.     } else {
  2004.         if (args[0].doubleValue >= (((double) LONG_MAX + 0.5))) {
  2005.         goto tooLarge;
  2006.         }
  2007.         resultPtr->intValue = (long) (args[0].doubleValue + 0.5);
  2008.     }
  2009.     }
  2010.     return TCL_OK;
  2011. }
  2012.  
  2013. /*
  2014.  *----------------------------------------------------------------------
  2015.  *
  2016.  * ExprLooksLikeInt --
  2017.  *
  2018.  *    This procedure decides whether the leading characters of a
  2019.  *    string look like an integer or something else (such as a
  2020.  *    floating-point number or string).
  2021.  *
  2022.  * Results:
  2023.  *    The return value is 1 if the leading characters of p look
  2024.  *    like a valid Tcl integer.  If they look like a floating-point
  2025.  *    number (e.g. "e01" or "2.4"), or if they don't look like a
  2026.  *    number at all, then 0 is returned.
  2027.  *
  2028.  * Side effects:
  2029.  *    None.
  2030.  *
  2031.  *----------------------------------------------------------------------
  2032.  */
  2033.  
  2034. static int
  2035. ExprLooksLikeInt(p)
  2036.     char *p;            /* Pointer to string. */
  2037. {
  2038.     while (isspace(UCHAR(*p))) {
  2039.     p++;
  2040.     }
  2041.     if ((*p == '+') || (*p == '-')) {
  2042.     p++;
  2043.     }
  2044.     if (!isdigit(UCHAR(*p))) {
  2045.     return 0;
  2046.     }
  2047.     p++;
  2048.     while (isdigit(UCHAR(*p))) {
  2049.     p++;
  2050.     }
  2051.     if ((*p != '.') && (*p != 'e') && (*p != 'E')) {
  2052.     return 1;
  2053.     }
  2054.     return 0;
  2055. }
  2056.