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