From: gah@grenache (George A. Howlett)
Newsgroups: comp.lang.tcl
Subject: Patch to add libm.a functions to Tcl 6.2 (tclExpr.c)
Date: 15 Apr 92 15:55:03 GMT
Reply-To: george.howlett@att.com
Organization: AT&T Bell Laboratories

Below is a patch which adds both exponentiation and some 
libm.a math library function support to the "expr" command.

The following patch was done on a Sun SS2 and assumes the 
math functions specified are available in libm.a and have 
forward declarations in /usr/include/math.h. Obviously, some 
of the functions are not found in other system's libm.a (rint, 
exp10, etc.) and the patched file will have to be edited.

Features:

* Exponentiation operator **:

  set a [expr $x**$y]

  Since it's very easy to generate values which are out of 
  the range of a signed/unsigned int, both operands are silently 
  promoted to TYPE_DOUBLE. (It may be advisable to do this for 
  multiplication also)

* Math library functions:

  Absolute value:
	abs
  Roots:
	sqrt, cbrt
  Rounding:
	ceil, floor, rint
  Trigonometric:  
	cos, sin, tan, asin, acos, atan, asinh
  Logarithm, exponential:
	log, log10, exp, exp10
  Promotion, demotion:
	int, float

  All math functions require a single argument and functions have the 
  same precedence as unary operators.  Basically I treat the function 
  name as a unary operator and require that a parenthesized expression 
  follow it, using the value of that expression as the argument to the
  function.

  set a [ expr cos($x)**2+sin($x)**2 ]
  set a [ expr log($a-$b) ]

  The only math error checking done is by inspecting errno 
  after invoking the function and setting errorCode if needed. 
  The format of errorCode is "MATHERR <EDOM|ERANGE> <function name>". 
  I don't know if more extensive checking is possible or necessary 
  (e.g. via matherr()). 

  The int and float do the obvious casting of values.

  # a = 0.25 not 0
  set b 1 ; set a [ expr float($b)/4 ] 

  # a = -3
  set a [ expr int(-3.3) ]


Problems:

* Some floating point values can be silently demoted to integers
  by the sprintf ("%g") call in the ExprMakeString routine.  The biggest
  problem is that you don't expect it. (Promoting multiplication
  operands eliminates much of the problem but may break some existing 
  code which may rely upon implicit demotion.) The following fragment 
  demonstrates how one must track intermediate values to be sure they
  are not demoted. 

  set a 100000.0 
  set b [ expr $a*1.0 ]
  set c [ expr $b*$b ]
  set d [ expr $a*$a ]

wish:   set a 100000.0 
100000.0
wish:   set b [ expr $a*1.0 ]
100000
wish:   set c [ expr $b*$b ]
1410065408
wish:   set d [ expr $a*$a ]
1e+10
   
  A very quick and dirty solution would be to check and see if the 
  resulting string (from sprintf) is not already in floating point
  format (i.e. has a 'E', 'e', or '.') and concatenate a ".0" on
  the end.  

------------------- patch starts here ---------------------
*** tclExpr.c-dist	Sun Dec 15 20:30:50 1991
--- tclExpr.c	Wed Apr 15 09:58:44 1992
***************
*** 22,27 ****
--- 22,28 ----
  #endif
  
  #include "tclInt.h"
+ #include <math.h>
  
  /*
   * The stuff below is a bit of a hack so that this file can be used
***************
*** 79,84 ****
--- 80,86 ----
  				 * expr.  See below for definitions.
  				 * Corresponds to the characters just
  				 * before expr. */
+     ClientData clientData;	/* Place to stash the function index */
  } ExprInfo;
  
  /*
***************
*** 96,102 ****
  /*
   * Binary operators:
   */
! 
  #define MULT		8
  #define DIVIDE		9
  #define MOD		10
--- 98,104 ----
  /*
   * Binary operators:
   */
! #define EXPON		7
  #define MULT		8
  #define DIVIDE		9
  #define MOD		10
***************
*** 126,137 ****
  #define NOT		29
  #define BIT_NOT		30
  
  /*
   * Precedence table.  The values for non-operator token types are ignored.
   */
  
  int precTable[] = {
!     0, 0, 0, 0, 0, 0, 0, 0,
      11, 11, 11,				/* MULT, DIVIDE, MOD */
      10, 10,				/* PLUS, MINUS */
      9, 9,				/* LEFT_SHIFT, RIGHT_SHIFT */
--- 128,180 ----
  #define NOT		29
  #define BIT_NOT		30
  
+ #define FUNCT		31	/* Not really unary operators, but we'll 
+ 				 * treat them as such */
+ struct MathLibraryFunctions {
+    char *name;
+    double (*ptr)_ANSI_ARGS_((double x));
+ };
+ 
+ /* The following symbols represent indices of each function in the 
+    math function table found below. */
+ enum FunctionIndices {
+   F_ABS, F_ACOS, F_ASIN, F_ASINH, F_ATAN, F_CBRT, F_CEIL, F_COS, F_EXP,
+   F_EXP10, F_FLOAT, F_FLOOR, F_INT, F_LOG, F_LOG10, F_RINT, F_SIN,
+   F_SQRT, F_TAN 
+ };
+ 
+ /* The data structure below contains the name and function pointer 
+    of libm.a math routines.  If you change this table, you must also
+    change the index table above. */
+ static struct MathLibraryFunctions mathLib [] = {
+     "abs", 	fabs,
+     "acos", 	acos, 
+     "asin", 	asin, 
+     "asinh", 	asinh, 
+     "atan", 	atan,
+     "cbrt", 	cbrt, 
+     "ceil", 	ceil, 
+     "cos", 	cos, 
+     "exp", 	exp, 
+     "exp10", 	exp10, 
+     "float",	NULL,	
+     "floor", 	floor,
+     "int",	NULL,	
+     "log", 	log, 
+     "log10", 	log10, 
+     "rint", 	rint, 
+     "sin", 	sin, 
+     "sqrt", 	sqrt,
+     "tan", 	tan,
+ };
+ 
  /*
   * Precedence table.  The values for non-operator token types are ignored.
   */
  
  int precTable[] = {
!     0, 0, 0, 0, 0, 0, 0, 
!     12,					/* EXPON */
      11, 11, 11,				/* MULT, DIVIDE, MOD */
      10, 10,				/* PLUS, MINUS */
      9, 9,				/* LEFT_SHIFT, RIGHT_SHIFT */
***************
*** 143,149 ****
      3,					/* AND */
      2,					/* OR */
      1, 1,				/* QUESTY, COLON */
!     12, 12, 12				/* UNARY_MINUS, NOT, BIT_NOT */
  };
  
  /*
--- 186,193 ----
      3,					/* AND */
      2,					/* OR */
      1, 1,				/* QUESTY, COLON */
!     13, 13, 13,				/* UNARY_MINUS, NOT, BIT_NOT */
!     13,					/* FUNCT */
  };
  
  /*
***************
*** 151,160 ****
   */
  
  char *operatorStrings[] = {
!     "VALUE", "(", ")", "END", "UNKNOWN", "5", "6", "7",
      "*", "/", "%", "+", "-", "<<", ">>", "<", ">", "<=",
      ">=", "==", "!=", "&", "^", "|", "&&", "||", "?", ":",
!     "-", "!", "~"
  };
  
  /*
--- 195,204 ----
   */
  
  char *operatorStrings[] = {
!     "VALUE", "(", ")", "END", "UNKNOWN", "5", "6", "**",
      "*", "/", "%", "+", "-", "<<", ">>", "<", ">", "<=",
      ">=", "==", "!=", "&", "^", "|", "&&", "||", "?", ":",
!     "-", "!", "~", "FUNCT"
  };
  
  /*
***************
*** 424,430 ****
  	    return TCL_OK;
  
  	case '*':
! 	    infoPtr->token = MULT;
  	    return TCL_OK;
  
  	case '/':
--- 468,479 ----
  	    return TCL_OK;
  
  	case '*':
! 	    if (p[1] == '*') {
! 	        infoPtr->token = EXPON;
! 	        infoPtr->expr = p+2;
! 	    } else {
! 	        infoPtr->token = MULT;
! 	    }
  	    return TCL_OK;
  
  	case '/':
***************
*** 533,540 ****
  	    return TCL_OK;
  
  	default:
! 	    infoPtr->expr = p+1;
! 	    infoPtr->token = UNKNOWN;
  	    return TCL_OK;
      }
  }
--- 582,591 ----
  	    return TCL_OK;
  
  	default:
! 	    if (ParseFunction (infoPtr, p) != TCL_OK) {
! 	        infoPtr->expr = p+1;
! 	        infoPtr->token = UNKNOWN;
! 	    }
  	    return TCL_OK;
      }
  }
***************
*** 626,635 ****
  	}
  	if (infoPtr->token >= UNARY_MINUS) {
  
  	    /*
  	     * Process unary operators.
  	     */
- 
  	    operator = infoPtr->token;
  	    result = ExprGetValue(interp, infoPtr, precTable[infoPtr->token],
  		    valuePtr);
--- 677,686 ----
  	}
  	if (infoPtr->token >= UNARY_MINUS) {
  
+ 	    int fnum = (int)infoPtr->clientData; /*Save the function index*/
  	    /*
  	     * Process unary operators.
  	     */
  	    operator = infoPtr->token;
  	    result = ExprGetValue(interp, infoPtr, precTable[infoPtr->token],
  		    valuePtr);
***************
*** 675,680 ****
--- 726,766 ----
  			goto illegalType;
  		    }
  		    break;
+                 case FUNCT:
+ 		    if (valuePtr->type == TYPE_STRING) {
+ 		        badType = valuePtr->type;
+ 			goto illegalType;
+ 		    } 
+ 		    switch (fnum) {
+ 		    case F_INT:
+  		        if (valuePtr->type == TYPE_DOUBLE) {
+ 			    valuePtr->intValue = valuePtr->doubleValue;
+ 			    valuePtr->type = TYPE_INT;
+ 			} 
+ 			break;
+ 		    case F_FLOAT:
+  		        if (valuePtr->type == TYPE_INT) {
+ 			    valuePtr->doubleValue = valuePtr->intValue;
+ 			    valuePtr->type = TYPE_DOUBLE;
+ 			  } 
+ 			break;
+ 		    default:
+  		        if (valuePtr->type == TYPE_INT) {
+ 			    valuePtr->doubleValue = valuePtr->intValue;
+ 			    valuePtr->type = TYPE_DOUBLE;
+ 			  } 
+ 			errno = 0;
+ 			valuePtr->doubleValue =  
+ 			    (*mathLib[fnum].ptr)(valuePtr->doubleValue);
+ 			if (errno == EDOM || errno == ERANGE) {
+ 			    Tcl_SetErrorCode (interp, "MATHERR", 
+ 				      (errno == EDOM) ? "EDOM" : "ERANGE",
+ 					      mathLib[fnum].name, NULL);
+ 			}
+ 			break;
+ 		    } 
+ 		    break;
+ 		    
  	    }
  	    gotOp = 1;
  	} else if (infoPtr->token != VALUE) {
***************
*** 695,701 ****
      while (1) {
  	operator = infoPtr->token;
  	value2.pv.next = value2.pv.buffer;
! 	if ((operator < MULT) || (operator >= UNARY_MINUS)) {
  	    if ((operator == END) || (operator == CLOSE_PAREN)) {
  		result = TCL_OK;
  		goto done;
--- 781,787 ----
      while (1) {
  	operator = infoPtr->token;
  	value2.pv.next = value2.pv.buffer;
! 	if ((operator < EXPON) || (operator >= UNARY_MINUS)) {
  	    if ((operator == END) || (operator == CLOSE_PAREN)) {
  		result = TCL_OK;
  		goto done;
***************
*** 770,776 ****
  	if (result != TCL_OK) {
  	    goto done;
  	}
! 	if ((infoPtr->token < MULT) && (infoPtr->token != VALUE)
  		&& (infoPtr->token != END)
  		&& (infoPtr->token != CLOSE_PAREN)) {
  	    goto syntaxError;
--- 856,862 ----
  	if (result != TCL_OK) {
  	    goto done;
  	}
! 	if ((infoPtr->token < EXPON) && (infoPtr->token != VALUE)
  		&& (infoPtr->token != END)
  		&& (infoPtr->token != CLOSE_PAREN)) {
  	    goto syntaxError;
***************
*** 786,791 ****
--- 872,897 ----
  	switch (operator) {
  
  	    /*
+ 	     * Unlike the binary operators below, force floating
+ 	     * point arithemetic to be done for exponentiation.
+ 	     */
+ 	    case EXPON:
+ 		if ((valuePtr->type == TYPE_STRING)
+ 			|| (value2.type == TYPE_STRING)) {
+ 		    badType = TYPE_STRING;
+ 		    goto illegalType;
+ 		}
+ 		if (value2.type == TYPE_INT) {
+ 		    value2.doubleValue = value2.intValue;
+ 		    value2.type = TYPE_DOUBLE;
+ 		} 
+ 		if (valuePtr->type == TYPE_INT) {
+ 		    valuePtr->doubleValue = valuePtr->intValue;
+ 		    valuePtr->type = TYPE_DOUBLE;
+ 		}
+ 		break;
+ 
+ 	    /*
  	     * For the operators below, no strings are allowed and
  	     * ints get converted to floats if necessary.
  	     */
***************
*** 808,814 ****
  		    }
  		}
  		break;
- 
  	    /*
  	     * For the operators below, only integers are allowed.
  	     */
--- 914,919 ----
***************
*** 895,900 ****
--- 1000,1009 ----
  	 */
  
  	switch (operator) {
+ 	    case EXPON:
+ 	        valuePtr->doubleValue = pow (valuePtr->doubleValue, 
+ 					     value2.doubleValue);
+ 		break;
  	    case MULT:
  		if (valuePtr->type == TYPE_INT) {
  		    valuePtr->intValue *= value2.intValue;
***************
*** 1334,1336 ****
--- 1443,1505 ----
      }
      return result;
  }
+ 
+ /*
+  *--------------------------------------------------------------
+  *
+  * ParseFunction --
+  *
+  *	Determine if the expression is a known math function
+  *	(which we are treating as an unary operator), and save the
+  *	the index to the math library function in the table.
+  *
+  * Results:
+  *	A standard Tcl result.  If the result is TCL_OK, infoPtr
+  *	is set (token is FUNCT, clientData is the index to the
+  *	math function entry).
+  *
+  * Side effects:
+  *	None.
+  *
+  *--------------------------------------------------------------
+  */
+ 
+ static int
+ ParseFunction (infoPtr, namePtr)
+     ExprInfo *infoPtr;		/* Describes the state of the parse. */
+     register char *namePtr;	/* Pointer to the start of the function name */
+ {
+   
+     register char *lastPtr = namePtr; /* Pointer to end of function name */
+     static int numLibraryFunctions = 
+ 	(sizeof (mathLib) / sizeof (struct MathLibraryFunctions));
+     register struct MathLibraryFunctions *funcPtr = mathLib;
+     int nameLength;
+     register int i;
+     char c;
+   
+     /* Find the end of the identifier */
+     while (isalnum(*lastPtr))
+ 	lastPtr++;
+     nameLength = lastPtr - namePtr;
+     /* Skip whitespace to get to the opening parenthesis */
+     while (isspace (*lastPtr))
+ 	lastPtr++;
+     if (*lastPtr != '(')
+ 	return TCL_ERROR;	/* Missing opening parenthesis */
+     c = *namePtr;
+     for (i = 0; i < numLibraryFunctions; i++, funcPtr++) {
+         if ((c == *funcPtr->name) && (nameLength == strlen (funcPtr->name)) &&
+ 	    (strncmp (namePtr, funcPtr->name, nameLength) == 0)) {
+ 
+ 	    /* Save the index to the function entry */
+ 	    infoPtr->clientData = (ClientData) i;
+ 	    infoPtr->expr = lastPtr;
+ 	    infoPtr->token = FUNCT;
+ 	    return (TCL_OK);
+ 	}
+     }
+     return (TCL_ERROR);
+ }
+ 
+