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