diff options
Diffstat (limited to 'generic/tclMathOp.c')
| -rw-r--r-- | generic/tclMathOp.c | 2884 |
1 files changed, 0 insertions, 2884 deletions
diff --git a/generic/tclMathOp.c b/generic/tclMathOp.c deleted file mode 100644 index 9858c00..0000000 --- a/generic/tclMathOp.c +++ /dev/null @@ -1,2884 +0,0 @@ -/* - * tclMathOp.c -- - * - * This file contains normal command versions of the contents of the - * tcl::mathop namespace. - * - * Copyright (c) 2006 by Donal K. Fellows. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclMathOp.c,v 1.8 2006/12/12 17:21:42 dgp Exp $ - */ - -/* - * NOTE: None of the routines in this file are currently in use. - * The file itself may be removed, but remains in place for now in - * case its routine may be useful during performance testing. - */ - -#if 0 - -#include "tclInt.h" -#include "tclCompile.h" -#include "tommath.h" -#include <math.h> -#include <float.h> - -/* - * Hack to determine whether we may expect IEEE floating point. The hack is - * formally incorrect in that non-IEEE platforms might have the same precision - * and range, but VAX, IBM, and Cray do not; are there any other floating - * point units that we might care about? - */ - -#if (FLT_RADIX == 2) && (DBL_MANT_DIG == 53) && (DBL_MAX_EXP == 1024) -#define IEEE_FLOATING_POINT -#endif - -/* - * The stuff below is a bit of a hack so that this file can be used in - * environments that include no UNIX. - * TODO: Does this serve any purpose anymore? - */ - -#ifdef TCL_GENERIC_ONLY -# ifndef NO_FLOAT_H -# include <float.h> -# else /* NO_FLOAT_H */ -# ifndef NO_VALUES_H -# include <values.h> -# endif /* !NO_VALUES_H */ -# endif /* !NO_FLOAT_H */ -#endif /* !TCL_GENERIC_ONLY */ - -/* - * Prototypes for helper functions defined in this file: - */ - -static Tcl_Obj * CombineIntFloat(Tcl_Interp *interp, Tcl_Obj *valuePtr, - int opcode, Tcl_Obj *value2Ptr); -static Tcl_Obj * CombineIntOnly(Tcl_Interp *interp, Tcl_Obj *valuePtr, - int opcode, Tcl_Obj *value2Ptr); -static int CompareNumbers(Tcl_Interp *interp, Tcl_Obj *numObj1, - Tcl_Obj *numObj2, int *resultPtr); - -/* - *---------------------------------------------------------------------- - * - * CombineIntFloat -- - * - * Parses and combines two numbers (either entier() or double()) - * according to the specified operation. - * - * Results: - * Returns the resulting number object (or NULL on failure). - * - * Side effects: - * None. - * - * Notes: - * This code originally extracted from tclExecute.c. - * - *---------------------------------------------------------------------- - */ - -static Tcl_Obj * -CombineIntFloat( - Tcl_Interp *interp, /* Place to write error messages. */ - Tcl_Obj *valuePtr, /* First value to combine. */ - int opcode, /* Operation to use to combine the - * values. Must be one of INST_ADD, INST_SUB, - * INST_MULT, INST_DIV or INST_EXPON. */ - Tcl_Obj *value2Ptr) /* Second value to combine. */ -{ - ClientData ptr1, ptr2; - int type1, type2; - Tcl_Obj *errPtr; - - if ((TclGetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) -#ifndef ACCEPT_NAN - || (type1 == TCL_NUMBER_NAN) -#endif - ) { - errPtr = valuePtr; - goto illegalOperand; - } - -#ifdef ACCEPT_NAN - if (type1 == TCL_NUMBER_NAN) { - /* NaN first argument -> result is also NaN */ - NEXT_INST_F(1, 1, 0); - } -#endif - - if ((TclGetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) -#ifndef ACCEPT_NAN - || (type2 == TCL_NUMBER_NAN) -#endif - ) { - errPtr = value2Ptr; - goto illegalOperand; - } - -#ifdef ACCEPT_NAN - if (type2 == TCL_NUMBER_NAN) { - /* NaN second argument -> result is also NaN */ - return value2Ptr; - NEXT_INST_F(1, 2, 1); - } -#endif - - if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) { - /* - * At least one of the values is floating-point, so perform floating - * point calculations. - */ - - double d1, d2, dResult; - Tcl_GetDoubleFromObj(NULL, valuePtr, &d1); - Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2); - - switch (opcode) { - case INST_ADD: - dResult = d1 + d2; - break; - case INST_SUB: - dResult = d1 - d2; - break; - case INST_MULT: - dResult = d1 * d2; - break; - case INST_DIV: -#ifndef IEEE_FLOATING_POINT - if (d2 == 0.0) { - goto divideByZero; - } -#endif - /* - * We presume that we are running with zero-divide unmasked if - * we're on an IEEE box. Otherwise, this statement might cause - * demons to fly out our noses. - */ - - dResult = d1 / d2; - break; - case INST_EXPON: - if (d1==0.0 && d2<0.0) { - goto exponOfZero; - } - dResult = pow(d1, d2); - break; - default: - /* Unused, here to silence compiler warning. */ - dResult = 0; - } - -#ifndef ACCEPT_NAN - /* - * Check now for IEEE floating-point error. - */ - - if (TclIsNaN(dResult)) { - TclExprFloatError(interp, dResult); - return NULL; - } -#endif - if (Tcl_IsShared(valuePtr)) { - return Tcl_NewDoubleObj(dResult); - } - Tcl_SetDoubleObj(valuePtr, dResult); - return valuePtr; - } - - if ((sizeof(long) >= 2*sizeof(int)) && (opcode == INST_MULT) - && (type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - long l1 = *((CONST long *)ptr1); - long l2 = *((CONST long *)ptr2); - if ((l1 <= INT_MAX) && (l1 >= INT_MIN) - && (l2 <= INT_MAX) && (l2 >= INT_MIN)) { - long lResult = l1 * l2; - - if (Tcl_IsShared(valuePtr)) { - return Tcl_NewLongObj(lResult); - } - Tcl_SetLongObj(valuePtr, lResult); - return valuePtr; - } - } - - if ((sizeof(Tcl_WideInt) >= 2*sizeof(long)) && (opcode == INST_MULT) - && (type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - Tcl_WideInt w1, w2, wResult; - Tcl_GetWideIntFromObj(NULL, valuePtr, &w1); - Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2); - - wResult = w1 * w2; - - if (Tcl_IsShared(valuePtr)) { - return Tcl_NewWideIntObj(wResult); - } - Tcl_SetWideIntObj(valuePtr, wResult); - return valuePtr; - } - - /* TODO: Attempts to re-use unshared operands on stack */ - if (opcode == INST_EXPON) { - long l1, l2 = 0; - int oddExponent = 0, negativeExponent = 0; - if (type2 == TCL_NUMBER_LONG) { - l2 = *((CONST long *)ptr2); - if (l2 == 0) { - /* Anything to the zero power is 1 */ - return Tcl_NewIntObj(1); - } - } - switch (type2) { - case TCL_NUMBER_LONG: { - negativeExponent = (l2 < 0); - oddExponent = (int) (l2 & 1); - break; - } -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: { - Tcl_WideInt w2 = *((CONST Tcl_WideInt *)ptr2); - negativeExponent = (w2 < 0); - oddExponent = (int) (w2 & (Tcl_WideInt)1); - break; - } -#endif - case TCL_NUMBER_BIG: { - mp_int big2; - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT); - mp_mod_2d(&big2, 1, &big2); - oddExponent = !mp_iszero(&big2); - mp_clear(&big2); - break; - } - } - - if (negativeExponent) { - if (type1 == TCL_NUMBER_LONG) { - l1 = *((CONST long *)ptr1); - switch (l1) { - case 0: - /* zero to a negative power is div by zero error */ - goto exponOfZero; - case -1: - if (oddExponent) { - return Tcl_NewIntObj(-1); - } else { - return Tcl_NewIntObj(1); - } - case 1: - /* 1 to any power is 1 */ - return Tcl_NewIntObj(1); - } - } - /* - * Integers with magnitude greater than 1 raise to a negative - * power yield the answer zero (see TIP 123) - */ - return Tcl_NewIntObj(0); - } - - if (type1 == TCL_NUMBER_LONG) { - l1 = *((CONST long *)ptr1); - switch (l1) { - case 0: - /* zero to a positive power is zero */ - return Tcl_NewIntObj(0); - case 1: - /* 1 to any power is 1 */ - return Tcl_NewIntObj(1); - case -1: - if (oddExponent) { - return Tcl_NewIntObj(-1); - } else { - return Tcl_NewIntObj(1); - } - } - } - if (type2 == TCL_NUMBER_BIG) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("exponent too large", -1)); - return NULL; - } - /* TODO: Perform those computations that fit in native types */ - goto overflow; - } - - if ((opcode != INST_MULT) - && (type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { - Tcl_WideInt w1, w2, wResult; - Tcl_GetWideIntFromObj(NULL, valuePtr, &w1); - Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2); - - switch (opcode) { - case INST_ADD: - wResult = w1 + w2; -#ifndef NO_WIDE_TYPE - if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) -#endif - { - /* Check for overflow */ - if (((w1 < 0) && (w2 < 0) && (wResult >= 0)) - || ((w1 > 0) && (w2 > 0) && (wResult < 0))) { - goto overflow; - } - } - break; - - case INST_SUB: - wResult = w1 - w2; -#ifndef NO_WIDE_TYPE - if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) -#endif - { - /* Must check for overflow */ - if (((w1 < 0) && (w2 > 0) && (wResult > 0)) - || ((w1 >= 0) && (w2 < 0) && (wResult < 0))) { - goto overflow; - } - } - break; - - case INST_DIV: - if (w2 == 0) { - goto divideByZero; - } - - /* Need a bignum to represent (LLONG_MIN / -1) */ - if ((w1 == LLONG_MIN) && (w2 == -1)) { - goto overflow; - } - wResult = w1 / w2; - - /* Force Tcl's integer division rules */ - /* TODO: examine for logic simplification */ - if (((wResult < 0) || ((wResult == 0) && - ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && - ((wResult * w2) != w1)) { - wResult -= 1; - } - break; - default: - /* Unused, here to silence compiler warning. */ - wResult = 0; - } - - if (Tcl_IsShared(valuePtr)) { - return Tcl_NewWideIntObj(wResult); - } - Tcl_SetWideIntObj(valuePtr, wResult); - return valuePtr; - } - - overflow: - { - mp_int big1, big2, bigResult, bigRemainder; - Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - mp_init(&bigResult); - switch (opcode) { - case INST_ADD: - mp_add(&big1, &big2, &bigResult); - break; - case INST_SUB: - mp_sub(&big1, &big2, &bigResult); - break; - case INST_MULT: - mp_mul(&big1, &big2, &bigResult); - break; - case INST_DIV: - if (mp_iszero(&big2)) { - mp_clear(&big1); - mp_clear(&big2); - goto divideByZero; - } - mp_init(&bigRemainder); - mp_div(&big1, &big2, &bigResult, &bigRemainder); - /* TODO: internals intrusion */ - if (!mp_iszero(&bigRemainder) - && (bigRemainder.sign != big2.sign)) { - /* Convert to Tcl's integer division rules */ - mp_sub_d(&bigResult, 1, &bigResult); - mp_add(&bigRemainder, &big2, &bigRemainder); - } - mp_clear(&bigRemainder); - break; - case INST_EXPON: - if (big2.used > 1) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("exponent too large", -1)); - mp_clear(&big1); - mp_clear(&big2); - return NULL; - } - mp_expt_d(&big1, big2.dp[0], &bigResult); - break; - } - mp_clear(&big1); - mp_clear(&big2); - if (Tcl_IsShared(valuePtr)) { - return Tcl_NewBignumObj(&bigResult); - } - Tcl_SetBignumObj(valuePtr, &bigResult); - return valuePtr; - } - - { - const char *description, *operator; - - illegalOperand: - switch (opcode) { - case INST_ADD: operator = "+"; break; - case INST_SUB: operator = "-"; break; - case INST_MULT: operator = "*"; break; - case INST_DIV: operator = "/"; break; - case INST_EXPON: operator = "**"; break; - default: - operator = "???"; - } - - if (TclGetNumberFromObj(NULL, errPtr, &ptr1, &type1) != TCL_OK) { - int numBytes; - CONST char *bytes = Tcl_GetStringFromObj(errPtr, &numBytes); - if (numBytes == 0) { - description = "empty string"; - } else if (TclCheckBadOctal(NULL, bytes)) { - description = "invalid octal number"; - } else { - description = "non-numeric string"; - } - } else if (type1 == TCL_NUMBER_NAN) { - description = "non-numeric floating-point value"; - } else if (type1 == TCL_NUMBER_DOUBLE) { - description = "floating-point value"; - } else { - /* TODO: No caller needs this. Eliminate? */ - description = "(big) integer"; - } - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use %s as operand of \"%s\"", description, operator)); - return NULL; - } - - divideByZero: - Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); - Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL); - return NULL; - - exponOfZero: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "exponentiation of zero by negative power", -1)); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", - "exponentiation of zero by negative power", NULL); - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * CombineIntOnly -- - * - * Parses and combines two numbers (must be entier()) according to the - * specified operation. - * - * Results: - * Returns the resulting number object (or NULL on failure). - * - * Side effects: - * None. - * - * Notes: - * This code originally extracted from tclExecute.c. - * - *---------------------------------------------------------------------- - */ - -static Tcl_Obj * -CombineIntOnly( - Tcl_Interp *interp, /* Place to write error messages. */ - Tcl_Obj *valuePtr, /* First value to combine. */ - int opcode, /* Operation to use to combine the - * values. Must be one of INST_BITAND, - * INST_BITOR or INST_BITXOR. */ - Tcl_Obj *value2Ptr) /* Second value to combine. */ -{ - ClientData ptr1, ptr2; - int type1, type2; - Tcl_Obj *errPtr; - - if ((TclGetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) - || (type1 == TCL_NUMBER_NAN) || (type1 == TCL_NUMBER_DOUBLE)) { - errPtr = valuePtr; - goto illegalOperand; - } - if ((TclGetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) - || (type2 == TCL_NUMBER_NAN) || (type2 == TCL_NUMBER_DOUBLE)) { - errPtr = value2Ptr; - goto illegalOperand; - } - - if ((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) { - mp_int big1, big2, bigResult; - mp_int *First, *Second; - int numPos; - - - Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - - /* - * Count how many positive arguments we have. If only one of the - * arguments is negative, store it in 'Second'. - */ - - if (mp_cmp_d(&big1, 0) != MP_LT) { - numPos = 1 + (mp_cmp_d(&big2, 0) != MP_LT); - First = &big1; - Second = &big2; - } else { - First = &big2; - Second = &big1; - numPos = (mp_cmp_d(First, 0) != MP_LT); - } - mp_init(&bigResult); - - switch (opcode) { - case INST_BITAND: - switch (numPos) { - case 2: - /* Both arguments positive, base case */ - mp_and(First, Second, &bigResult); - break; - case 1: - /* First is positive; Second negative - * P & N = P & ~~N = P&~(-N-1) = P & (P ^ (-N-1)) */ - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_xor(First, Second, &bigResult); - mp_and(First, &bigResult, &bigResult); - break; - case 0: - /* Both arguments negative - * a & b = ~ (~a | ~b) = -(-a-1|-b-1)-1 */ - mp_neg(First, First); - mp_sub_d(First, 1, First); - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_or(First, Second, &bigResult); - mp_neg(&bigResult, &bigResult); - mp_sub_d(&bigResult, 1, &bigResult); - break; - } - break; - - case INST_BITOR: - switch (numPos) { - case 2: - /* Both arguments positive, base case */ - mp_or(First, Second, &bigResult); - break; - case 1: - /* First is positive; Second negative - * N|P = ~(~N&~P) = ~((-N-1)&~P) = -((-N-1)&((-N-1)^P))-1 */ - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_xor(First, Second, &bigResult); - mp_and(Second, &bigResult, &bigResult); - mp_neg(&bigResult, &bigResult); - mp_sub_d(&bigResult, 1, &bigResult); - break; - case 0: - /* Both arguments negative - * a | b = ~ (~a & ~b) = -(-a-1&-b-1)-1 */ - mp_neg(First, First); - mp_sub_d(First, 1, First); - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_and(First, Second, &bigResult); - mp_neg(&bigResult, &bigResult); - mp_sub_d(&bigResult, 1, &bigResult); - break; - } - break; - - case INST_BITXOR: - switch (numPos) { - case 2: - /* Both arguments positive, base case */ - mp_xor(First, Second, &bigResult); - break; - case 1: - /* First is positive; Second negative - * P^N = ~(P^~N) = -(P^(-N-1))-1 */ - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_xor(First, Second, &bigResult); - mp_neg(&bigResult, &bigResult); - mp_sub_d(&bigResult, 1, &bigResult); - break; - case 0: - /* Both arguments negative - * a ^ b = (~a ^ ~b) = (-a-1^-b-1) */ - mp_neg(First, First); - mp_sub_d(First, 1, First); - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_xor(First, Second, &bigResult); - break; - } - break; - } - - mp_clear(&big1); - mp_clear(&big2); - if (Tcl_IsShared(valuePtr)) { - return Tcl_NewBignumObj(&bigResult); - } - Tcl_SetBignumObj(valuePtr, &bigResult); - return valuePtr; - } -#ifndef NO_WIDE_TYPE - else if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { - Tcl_WideInt wResult, w1, w2; - Tcl_GetWideIntFromObj(NULL, valuePtr, &w1); - Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2); - - switch (opcode) { - case INST_BITAND: - wResult = w1 & w2; - break; - case INST_BITOR: - wResult = w1 | w2; - break; - case INST_BITXOR: - wResult = w1 ^ w2; - break; - default: - /* Unused, here to silence compiler warning. */ - wResult = 0; - } - - if (Tcl_IsShared(valuePtr)) { - return Tcl_NewWideIntObj(wResult); - } - Tcl_SetWideIntObj(valuePtr, wResult); - return valuePtr; - } -#endif - else { - long lResult, l1 = *((const long *)ptr1); - long l2 = *((const long *)ptr2); - - switch (opcode) { - case INST_BITAND: - lResult = l1 & l2; - break; - case INST_BITOR: - lResult = l1 | l2; - break; - case INST_BITXOR: - lResult = l1 ^ l2; - break; - default: - /* Unused, here to silence compiler warning. */ - lResult = 0; - } - - if (Tcl_IsShared(valuePtr)) { - return Tcl_NewLongObj(lResult); - } - TclSetLongObj(valuePtr, lResult); - return valuePtr; - } - - { - const char *description, *operator; - - illegalOperand: - switch (opcode) { - case INST_BITAND: operator = "&"; break; - case INST_BITOR: operator = "|"; break; - case INST_BITXOR: operator = "^"; break; - default: - operator = "???"; - } - - if (TclGetNumberFromObj(NULL, errPtr, &ptr1, &type1) != TCL_OK) { - int numBytes; - CONST char *bytes = Tcl_GetStringFromObj(errPtr, &numBytes); - if (numBytes == 0) { - description = "empty string"; - } else if (TclCheckBadOctal(NULL, bytes)) { - description = "invalid octal number"; - } else { - description = "non-numeric string"; - } - } else if (type1 == TCL_NUMBER_NAN) { - description = "non-numeric floating-point value"; - } else if (type1 == TCL_NUMBER_DOUBLE) { - description = "floating-point value"; - } else { - /* TODO: No caller needs this. Eliminate? */ - description = "(big) integer"; - } - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use %s as operand of \"%s\"", description, operator)); - return NULL; - } -} - -/* - *---------------------------------------------------------------------- - * - * CompareNumbers -- - * - * Parses and compares two numbers (may be either entier() or double()). - * - * Results: - * TCL_OK if the numbers parse correctly, TCL_ERROR if one is not numeric - * at all, and TCL_BREAK if one or the other is "NaN". The resultPtr - * argument is used to update a variable with how the numbers relate to - * each other in the TCL_OK case. - * - * Side effects: - * None. - * - * Notes: - * This code originally extracted from tclExecute.c. - * - *---------------------------------------------------------------------- - */ - -static int -CompareNumbers( - Tcl_Interp *interp, /* Where to write error messages if any. */ - Tcl_Obj *numObj1, /* First number to compare. */ - Tcl_Obj *numObj2, /* Second number to compare. */ - int *resultPtr) /* Pointer to a variable to write the outcome - * of the comparison into. Must not be - * NULL. */ -{ - ClientData ptr1, ptr2; - int type1, type2; - double d1, d2, tmp; - long l1, l2; - mp_int big1, big2; -#ifndef NO_WIDE_TYPE - Tcl_WideInt w1, w2; -#endif - - if (TclGetNumberFromObj(interp, numObj1, &ptr1, &type1) != TCL_OK) { - return TCL_ERROR; - } - if (TclGetNumberFromObj(interp, numObj2, &ptr2, &type2) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Selected special cases. NaNs are not equal to *everything*, otherwise - * objects are equal to themselves. - */ - - if (type1 == TCL_NUMBER_NAN) { - /* NaN first arg: NaN != to everything, other compares are false */ - return TCL_BREAK; - } - if (numObj1 == numObj2) { - *resultPtr = MP_EQ; - return TCL_OK; - } - if (type2 == TCL_NUMBER_NAN) { - /* NaN 2nd arg: NaN != to everything, other compares are false */ - return TCL_BREAK; - } - - /* - * Big switch to pick apart the type rules and choose how to compare the - * two numbers. Also handles a few special cases along the way. - */ - - switch (type1) { - case TCL_NUMBER_LONG: - l1 = *((CONST long *)ptr1); - switch (type2) { - case TCL_NUMBER_LONG: - l2 = *((CONST long *)ptr2); - goto longCompare; -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - w2 = *((CONST Tcl_WideInt *)ptr2); - w1 = (Tcl_WideInt)l1; - goto wideCompare; -#endif - case TCL_NUMBER_DOUBLE: - d2 = *((CONST double *)ptr2); - d1 = (double) l1; - - /* - * If the double has a fractional part, or if the long can be - * converted to double without loss of precision, then compare as - * doubles. - */ - - if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long)) - || (l1 == (long) d1) || (modf(d2, &tmp) != 0.0)) { - goto doubleCompare; - } - - /* - * Otherwise, to make comparision based on full precision, need to - * convert the double to a suitably sized integer. - * - * Need this to get comparsions like - * expr 20000000000000003 < 20000000000000004.0 - * right. Converting the first argument to double will yield two - * double values that are equivalent within double precision. - * Converting the double to an integer gets done exactly, then - * integer comparison can tell the difference. - */ - - if (d2 < (double)LONG_MIN) { - *resultPtr = MP_GT; - return TCL_OK; - } - if (d2 > (double)LONG_MAX) { - *resultPtr = MP_LT; - return TCL_OK; - } - l2 = (long) d2; - goto longCompare; - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, numObj2, &big2); - if (mp_cmp_d(&big2, 0) == MP_LT) { - *resultPtr = MP_GT; - } else { - *resultPtr = MP_LT; - } - mp_clear(&big2); - } - return TCL_OK; - -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - w1 = *((CONST Tcl_WideInt *)ptr1); - switch (type2) { - case TCL_NUMBER_WIDE: - w2 = *((CONST Tcl_WideInt *)ptr2); - goto wideCompare; - case TCL_NUMBER_LONG: - l2 = *((CONST long *)ptr2); - w2 = (Tcl_WideInt)l2; - goto wideCompare; - case TCL_NUMBER_DOUBLE: - d2 = *((CONST double *)ptr2); - d1 = (double) w1; - if ((DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)) - || (w1 == (Tcl_WideInt) d1) || (modf(d2, &tmp) != 0.0)) { - goto doubleCompare; - } - if (d2 < (double)LLONG_MIN) { - *resultPtr = MP_GT; - return TCL_OK; - } - if (d2 > (double)LLONG_MAX) { - *resultPtr = MP_LT; - return TCL_OK; - } - w2 = (Tcl_WideInt) d2; - goto wideCompare; - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, numObj2, &big2); - if (mp_cmp_d(&big2, 0) == MP_LT) { - *resultPtr = MP_GT; - } else { - *resultPtr = MP_LT; - } - mp_clear(&big2); - } - return TCL_OK; -#endif - - case TCL_NUMBER_DOUBLE: - d1 = *((CONST double *)ptr1); - switch (type2) { - case TCL_NUMBER_DOUBLE: - d2 = *((CONST double *)ptr2); - goto doubleCompare; - case TCL_NUMBER_LONG: - l2 = *((CONST long *)ptr2); - d2 = (double) l2; - - if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long)) - || (l2 == (long) d2) || (modf(d1, &tmp) != 0.0)) { - goto doubleCompare; - } - if (d1 < (double)LONG_MIN) { - *resultPtr = MP_LT; - return TCL_OK; - } - if (d1 > (double)LONG_MAX) { - *resultPtr = MP_GT; - return TCL_OK; - } - l1 = (long) d1; - goto longCompare; -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - w2 = *((CONST Tcl_WideInt *)ptr2); - d2 = (double) w2; - if ((DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)) - || (w2 == (Tcl_WideInt) d2) || (modf(d1, &tmp) != 0.0)) { - goto doubleCompare; - } - if (d1 < (double)LLONG_MIN) { - *resultPtr = MP_LT; - return TCL_OK; - } - if (d1 > (double)LLONG_MAX) { - *resultPtr = MP_GT; - return TCL_OK; - } - w1 = (Tcl_WideInt) d1; - goto wideCompare; -#endif - case TCL_NUMBER_BIG: - if (TclIsInfinite(d1)) { - *resultPtr = (d1 > 0.0) ? MP_GT : MP_LT; - return TCL_OK; - } - Tcl_TakeBignumFromObj(NULL, numObj2, &big2); - if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) { - if (mp_cmp_d(&big2, 0) == MP_LT) { - *resultPtr = MP_GT; - } else { - *resultPtr = MP_LT; - } - mp_clear(&big2); - return TCL_OK; - } - if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long)) - && (modf(d1, &tmp) != 0.0)) { - d2 = TclBignumToDouble(&big2); - mp_clear(&big2); - goto doubleCompare; - } - Tcl_InitBignumFromDouble(NULL, d1, &big1); - goto bigCompare; - } - return TCL_OK; - - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, numObj1, &big1); - switch (type2) { -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: -#endif - case TCL_NUMBER_LONG: - *resultPtr = mp_cmp_d(&big1, 0); - mp_clear(&big1); - return TCL_OK; - case TCL_NUMBER_DOUBLE: - d2 = *((CONST double *)ptr2); - if (TclIsInfinite(d2)) { - *resultPtr = (d2 > 0.0) ? MP_LT : MP_GT; - mp_clear(&big1); - return TCL_OK; - } - if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) { - *resultPtr = mp_cmp_d(&big1, 0); - mp_clear(&big1); - return TCL_OK; - } - if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long)) - && (modf(d2, &tmp) != 0.0)) { - d1 = TclBignumToDouble(&big1); - mp_clear(&big1); - goto doubleCompare; - } - Tcl_InitBignumFromDouble(NULL, d2, &big2); - goto bigCompare; - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, numObj2, &big2); - goto bigCompare; - } - } - - /* - * Should really be impossible to get here - */ - - return TCL_OK; - - /* - * The real core comparison rules. - */ - - longCompare: - *resultPtr = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); - return TCL_OK; -#ifndef NO_WIDE_TYPE - wideCompare: - *resultPtr = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); - return TCL_OK; -#endif - doubleCompare: - *resultPtr = (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ); - return TCL_OK; - bigCompare: - *resultPtr = mp_cmp(&big1, &big2); - mp_clear(&big1); - mp_clear(&big2); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclInvertOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::~" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclInvertOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - ClientData val; - int type; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "number"); - return TCL_ERROR; - } - if (TclGetNumberFromObj(NULL, objv[1], &val, &type) != TCL_OK) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't use non-numeric string as operand of \"~\"", -1)); - return TCL_ERROR; - } - switch (type) { - case TCL_NUMBER_NAN: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use %s as operand of \"~\"", - "non-numeric floating-point value")); - return TCL_ERROR; - case TCL_NUMBER_DOUBLE: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use %s as operand of \"~\"", "floating-point value")); - return TCL_ERROR; - case TCL_NUMBER_LONG: { - long l = *((const long *) val); - - Tcl_SetLongObj(Tcl_GetObjResult(interp), ~l); - return TCL_OK; - } -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: { - Tcl_WideInt w = *((const Tcl_WideInt *) val); - - Tcl_SetWideIntObj(Tcl_GetObjResult(interp), ~w); - return TCL_OK; - } -#endif - default: { - mp_int big; - - Tcl_TakeBignumFromObj(NULL, objv[1], &big); - /* ~a = - a - 1 */ - mp_neg(&big, &big); - mp_sub_d(&big, 1, &big); - if (Tcl_IsShared(objv[1])) { - Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); - } else { - Tcl_SetBignumObj(objv[1], &big); - Tcl_SetObjResult(interp, objv[1]); - } - return TCL_OK; - } - } -} - -/* - *---------------------------------------------------------------------- - * - * TclNotOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::!" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclNotOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - int b; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "boolean"); - return TCL_ERROR; - } - if (Tcl_GetBooleanFromObj(NULL, objv[1], &b) != TCL_OK) { - int type; - ClientData val; - if (TclGetNumberFromObj(NULL, objv[1], &val, &type) == TCL_OK) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't use non-numeric floating-point value as operand of \"!\"", -1)); - } else { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't use non-numeric string as operand of \"!\"", -1)); - } - return TCL_ERROR; - } - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), !b); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclAddOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::+" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclAddOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - if (objc < 2) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); - return TCL_OK; - } else if (objc == 2) { - ClientData ptr1; - int type1; - if (TclGetNumberFromObj(NULL, objv[1], &ptr1, &type1) != TCL_OK) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't use non-numeric string as operand of \"+\"",-1)); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; - } else if (objc == 3) { - /* - * This is a special case of the version with the loop that allows for - * better memory management of objects in some cases. - */ - - Tcl_Obj *resPtr = CombineIntFloat(interp, objv[1], INST_ADD, objv[2]); - if (resPtr == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, resPtr); - return TCL_OK; - } else { - Tcl_Obj *sumPtr = objv[1]; - int i; - - Tcl_IncrRefCount(sumPtr); - for (i=2 ; i<objc ; i++) { - Tcl_Obj *resPtr = CombineIntFloat(interp, sumPtr, INST_ADD, - objv[i]); - - if (resPtr == NULL) { - TclDecrRefCount(sumPtr); - return TCL_ERROR; - } - Tcl_IncrRefCount(resPtr); - TclDecrRefCount(sumPtr); - sumPtr = resPtr; - } - Tcl_SetObjResult(interp, sumPtr); - Tcl_DecrRefCount(sumPtr); /* Public form since we know we won't - * be freeing this object now. */ - return TCL_OK; - } -} - -/* - *---------------------------------------------------------------------- - * - * TclMulOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::*" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclMulOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - if (objc < 2) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); - return TCL_OK; - } else if (objc == 2) { - ClientData ptr1; - int type1; - if (TclGetNumberFromObj(NULL, objv[1], &ptr1, &type1) != TCL_OK) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't use non-numeric string as operand of \"*\"",-1)); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; - } else if (objc == 3) { - /* - * This is a special case of the version with the loop that allows for - * better memory management of objects in some cases. - */ - - Tcl_Obj *resPtr = CombineIntFloat(interp, objv[1],INST_MULT,objv[2]); - if (resPtr == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, resPtr); - return TCL_OK; - } else { - Tcl_Obj *prodPtr = objv[1]; - int i; - - Tcl_IncrRefCount(prodPtr); - for (i=2 ; i<objc ; i++) { - Tcl_Obj *resPtr = CombineIntFloat(interp, prodPtr, INST_MULT, - objv[i]); - - if (resPtr == NULL) { - TclDecrRefCount(prodPtr); - return TCL_ERROR; - } - Tcl_IncrRefCount(resPtr); - TclDecrRefCount(prodPtr); - prodPtr = resPtr; - } - Tcl_SetObjResult(interp, prodPtr); - Tcl_DecrRefCount(prodPtr); /* Public form since we know we won't - * be freeing this object now. */ - return TCL_OK; - } -} - -/* - *---------------------------------------------------------------------- - * - * TclAndOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::&" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclAndOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - if (objc < 2) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), -1); - return TCL_OK; - } else if (objc == 2) { - ClientData ptr1; - int type1; - if (TclGetNumberFromObj(NULL, objv[1], &ptr1, &type1) != TCL_OK) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't use non-numeric string as operand of \"&\"",-1)); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; - } else if (objc == 3) { - /* - * This is a special case of the version with the loop that allows for - * better memory management of objects in some cases. - */ - - Tcl_Obj *resPtr = CombineIntOnly(interp, objv[1],INST_BITAND,objv[2]); - if (resPtr == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, resPtr); - return TCL_OK; - } else { - Tcl_Obj *accumPtr = objv[1]; - int i; - - Tcl_IncrRefCount(accumPtr); - for (i=2 ; i<objc ; i++) { - Tcl_Obj *resPtr = CombineIntOnly(interp, accumPtr, INST_BITAND, - objv[i]); - - if (resPtr == NULL) { - TclDecrRefCount(accumPtr); - return TCL_ERROR; - } - Tcl_IncrRefCount(resPtr); - TclDecrRefCount(accumPtr); - accumPtr = resPtr; - } - Tcl_SetObjResult(interp, accumPtr); - Tcl_DecrRefCount(accumPtr); /* Public form since we know we won't - * be freeing this object now. */ - return TCL_OK; - } -} - -/* - *---------------------------------------------------------------------- - * - * TclOrOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::|" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclOrOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - if (objc < 2) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); - return TCL_OK; - } else if (objc == 2) { - ClientData ptr1; - int type1; - if (TclGetNumberFromObj(NULL, objv[1], &ptr1, &type1) != TCL_OK) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't use non-numeric string as operand of \"|\"",-1)); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; - } else if (objc == 3) { - /* - * This is a special case of the version with the loop that allows for - * better memory management of objects in some cases. - */ - - Tcl_Obj *resPtr = CombineIntOnly(interp, objv[1],INST_BITOR,objv[2]); - if (resPtr == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, resPtr); - return TCL_OK; - } else { - Tcl_Obj *accumPtr = objv[1]; - int i; - - Tcl_IncrRefCount(accumPtr); - for (i=2 ; i<objc ; i++) { - Tcl_Obj *resPtr = CombineIntOnly(interp, accumPtr, INST_BITOR, - objv[i]); - - if (resPtr == NULL) { - TclDecrRefCount(accumPtr); - return TCL_ERROR; - } - Tcl_IncrRefCount(resPtr); - TclDecrRefCount(accumPtr); - accumPtr = resPtr; - } - Tcl_SetObjResult(interp, accumPtr); - Tcl_DecrRefCount(accumPtr); /* Public form since we know we won't - * be freeing this object now. */ - return TCL_OK; - } -} - -/* - *---------------------------------------------------------------------- - * - * TclXorOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::^" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclXorOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - if (objc < 2) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); - return TCL_OK; - } else if (objc == 2) { - ClientData ptr1; - int type1; - if (TclGetNumberFromObj(NULL, objv[1], &ptr1, &type1) != TCL_OK) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't use non-numeric string as operand of \"^\"",-1)); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; - } else if (objc == 3) { - /* - * This is a special case of the version with the loop that allows for - * better memory management of objects in some cases. - */ - - Tcl_Obj *resPtr = CombineIntOnly(interp, objv[1],INST_BITXOR,objv[2]); - if (resPtr == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, resPtr); - return TCL_OK; - } else { - Tcl_Obj *accumPtr = objv[1]; - int i; - - Tcl_IncrRefCount(accumPtr); - for (i=2 ; i<objc ; i++) { - Tcl_Obj *resPtr = CombineIntOnly(interp, accumPtr, INST_BITXOR, - objv[i]); - - if (resPtr == NULL) { - TclDecrRefCount(accumPtr); - return TCL_ERROR; - } - Tcl_IncrRefCount(resPtr); - TclDecrRefCount(accumPtr); - accumPtr = resPtr; - } - Tcl_SetObjResult(interp, accumPtr); - Tcl_DecrRefCount(accumPtr); /* Public form since we know we won't - * be freeing this object now. */ - return TCL_OK; - } -} - -/* - *---------------------------------------------------------------------- - * - * TclPowOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::**" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclPowOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - if (objc < 2) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); - return TCL_OK; - } else if (objc == 2) { - ClientData ptr1; - int type1; - if (TclGetNumberFromObj(NULL, objv[1], &ptr1, &type1) != TCL_OK) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't use non-numeric string as operand of \"**\"",-1)); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; - } else if (objc == 3) { - /* - * This is a special case of the version with the loop that allows for - * better memory management of objects in some cases. - */ - - Tcl_Obj *resPtr = CombineIntFloat(interp, objv[1],INST_EXPON,objv[2]); - if (resPtr == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, resPtr); - return TCL_OK; - } else { - Tcl_Obj *powPtr = objv[objc-1]; - int i; - - Tcl_IncrRefCount(powPtr); - for (i=objc-2 ; i>=1 ; i--) { - Tcl_Obj *resPtr = CombineIntFloat(interp, objv[i], INST_EXPON, - powPtr); - - if (resPtr == NULL) { - TclDecrRefCount(powPtr); - return TCL_ERROR; - } - Tcl_IncrRefCount(resPtr); - TclDecrRefCount(powPtr); - powPtr = resPtr; - } - Tcl_SetObjResult(interp, powPtr); - Tcl_DecrRefCount(powPtr); /* Public form since we know we won't - * be freeing this object now. */ - return TCL_OK; - } -} - -/* - *---------------------------------------------------------------------- - * - * TclMinusOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::-" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclMinusOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "value ?value ...?"); - return TCL_ERROR; - } else if (objc == 2) { - /* - * Only a single argument, so we compute the negation. - */ - - Tcl_Obj *zeroPtr = Tcl_NewIntObj(0); - Tcl_Obj *resPtr; - - Tcl_IncrRefCount(zeroPtr); - resPtr = CombineIntFloat(interp, zeroPtr, INST_SUB, objv[1]); - if (resPtr == NULL) { - TclDecrRefCount(zeroPtr); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, resPtr); - TclDecrRefCount(zeroPtr); - return TCL_OK; - } else if (objc == 3) { - /* - * This is a special case of the version with the loop that allows for - * better memory management of objects in some cases. - */ - - Tcl_Obj *resPtr = CombineIntFloat(interp, objv[1], INST_SUB, objv[2]); - if (resPtr == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, resPtr); - return TCL_OK; - } else { - Tcl_Obj *diffPtr = objv[1]; - int i; - - Tcl_IncrRefCount(diffPtr); - for (i=2 ; i<objc ; i++) { - Tcl_Obj *resPtr = CombineIntFloat(interp, diffPtr, INST_SUB, - objv[i]); - - if (resPtr == NULL) { - TclDecrRefCount(diffPtr); - return TCL_ERROR; - } - Tcl_IncrRefCount(resPtr); - TclDecrRefCount(diffPtr); - diffPtr = resPtr; - } - Tcl_SetObjResult(interp, diffPtr); - Tcl_DecrRefCount(diffPtr); /* Public form since we know we won't - * be freeing this object now. */ - return TCL_OK; - } -} - -/* - *---------------------------------------------------------------------- - * - * TclDivOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::/" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclDivOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "value ?value ...?"); - return TCL_ERROR; - } else if (objc == 2) { - /* - * Only a single argument, so we compute the reciprocal. - */ - - Tcl_Obj *onePtr = Tcl_NewDoubleObj(1.0); - Tcl_Obj *resPtr; - - Tcl_IncrRefCount(onePtr); - resPtr = CombineIntFloat(interp, onePtr, INST_DIV, objv[1]); - if (resPtr == NULL) { - TclDecrRefCount(onePtr); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, resPtr); - TclDecrRefCount(onePtr); - return TCL_OK; - } else if (objc == 3) { - /* - * This is a special case of the version with the loop that allows for - * better memory management of objects in some cases. - */ - - Tcl_Obj *resPtr = CombineIntFloat(interp, objv[1], INST_DIV, objv[2]); - if (resPtr == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, resPtr); - return TCL_OK; - } else { - Tcl_Obj *numeratorPtr = objv[1]; - int i; - - Tcl_IncrRefCount(numeratorPtr); - for (i=2 ; i<objc ; i++) { - Tcl_Obj *resPtr = CombineIntFloat(interp, numeratorPtr, INST_DIV, - objv[i]); - - if (resPtr == NULL) { - TclDecrRefCount(numeratorPtr); - return TCL_ERROR; - } - Tcl_IncrRefCount(resPtr); - TclDecrRefCount(numeratorPtr); - numeratorPtr = resPtr; - } - Tcl_SetObjResult(interp, numeratorPtr); - Tcl_DecrRefCount(numeratorPtr); /* Public form since we know we won't - * be freeing this object now. */ - return TCL_OK; - } -} - -/* - *---------------------------------------------------------------------- - * - * TclLshiftOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::<<" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclLshiftOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - ClientData ptr1, ptr2; - int invalid, shift, type1, type2, idx; - const char *description; - long l1; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "value value"); - return TCL_ERROR; - } - - if ((TclGetNumberFromObj(NULL, objv[1], &ptr1, &type1) != TCL_OK) - || (type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { - idx = 1; - goto illegalOperand; - } - if ((TclGetNumberFromObj(NULL, objv[2], &ptr2, &type2) != TCL_OK) - || (type2 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_NAN)) { - idx = 2; - goto illegalOperand; - } - - /* reject negative shift argument */ - switch (type2) { - case TCL_NUMBER_LONG: - invalid = (*((const long *)ptr2) < (long)0); - break; -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); - break; -#endif - case TCL_NUMBER_BIG: - /* TODO: const correctness ? */ - invalid = (mp_cmp_d((mp_int *)ptr2, 0) == MP_LT); - break; - default: - /* Unused, here to silence compiler warning */ - invalid = 0; - } - if (invalid) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("negative shift argument", -1)); - return TCL_ERROR; - } - - /* Zero shifted any number of bits is still zero */ - if ((type1 == TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); - return TCL_OK; - } - - /* Large left shifts create integer overflow */ - if ((type2 != TCL_NUMBER_LONG) - || (*((const long *)ptr2) > (long) INT_MAX)) { - /* - * Technically, we could hold the value (1 << (INT_MAX+1)) in an - * mp_int, but since we're using mp_mul_2d() to do the work, and it - * takes only an int argument, that's a good place to draw the line. - */ - - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent", -1)); - return TCL_ERROR; - } - shift = (int)(*((const long *)ptr2)); - - /* Handle shifts within the native long range */ - if ((type1 == TCL_NUMBER_LONG) && ((size_t)shift < CHAR_BIT*sizeof(long)) - && (l1 = *((CONST long *)ptr1)) && - !(((l1>0) ? l1 : ~l1) & -(1L<<(CHAR_BIT*sizeof(long)-1-shift)))) { - Tcl_SetObjResult(interp, Tcl_NewLongObj(l1<<shift)); - return TCL_OK; - } - - /* Handle shifts within the native wide range */ - if ((type1 != TCL_NUMBER_BIG) - && ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) { - Tcl_WideInt w; - - Tcl_GetWideIntFromObj(NULL, objv[1], &w); - if (!(((w>0) ? w : ~w) & -(((Tcl_WideInt)1) - << (CHAR_BIT*sizeof(Tcl_WideInt)-1-shift)))) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(w<<shift)); - return TCL_OK; - } - } - - { - mp_int big, bigResult; - - Tcl_TakeBignumFromObj(NULL, objv[1], &big); - - mp_init(&bigResult); - mp_mul_2d(&big, shift, &bigResult); - mp_clear(&big); - - if (!Tcl_IsShared(objv[1])) { - Tcl_SetBignumObj(objv[1], &bigResult); - Tcl_SetObjResult(interp, objv[1]); - } else { - Tcl_SetObjResult(interp, Tcl_NewBignumObj(&bigResult)); - } - } - return TCL_OK; - - illegalOperand: - if (TclGetNumberFromObj(NULL, objv[idx], &ptr1, &type1) != TCL_OK) { - int numBytes; - const char *bytes = Tcl_GetStringFromObj(objv[idx], &numBytes); - if (numBytes == 0) { - description = "empty string"; - } else if (TclCheckBadOctal(NULL, bytes)) { - description = "invalid octal number"; - } else { - description = "non-numeric string"; - } - } else if (type1 == TCL_NUMBER_NAN) { - description = "non-numeric floating-point value"; - } else { - description = "floating-point value"; - } - - Tcl_SetObjResult(interp, - Tcl_ObjPrintf("can't use %s as operand of \"<<\"", description)); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * TclRshiftOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::>>" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclRshiftOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - ClientData ptr1, ptr2; - int invalid, shift, type1, type2, idx; - const char *description; - long l1; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "value value"); - return TCL_ERROR; - } - - if ((TclGetNumberFromObj(NULL, objv[1], &ptr1, &type1) != TCL_OK) - || (type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { - idx = 1; - goto illegalOperand; - } - if ((TclGetNumberFromObj(NULL, objv[2], &ptr2, &type2) != TCL_OK) - || (type2 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_NAN)) { - idx = 2; - goto illegalOperand; - } - - /* reject negative shift argument */ - switch (type2) { - case TCL_NUMBER_LONG: - invalid = (*((const long *)ptr2) < (long)0); - break; -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); - break; -#endif - case TCL_NUMBER_BIG: - /* TODO: const correctness ? */ - invalid = (mp_cmp_d((mp_int *)ptr2, 0) == MP_LT); - break; - default: - /* Unused, here to silence compiler warning */ - invalid = 0; - } - if (invalid) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("negative shift argument", -1)); - return TCL_ERROR; - } - - /* Zero shifted any number of bits is still zero */ - if ((type1 == TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); - return TCL_OK; - } - - /* Quickly force large right shifts to 0 or -1 */ - if ((type2 != TCL_NUMBER_LONG) - || (*((const long *)ptr2) > INT_MAX)) { - /* - * Again, technically, the value to be shifted could be an mp_int so - * huge that a right shift by (INT_MAX+1) bits could not take us to - * the result of 0 or -1, but since we're using mp_div_2d to do the - * work, and it takes only an int argument, we draw the line there. - */ - - int zero; - - switch (type1) { - case TCL_NUMBER_LONG: - zero = (*((const long *)ptr1) > (long)0); - break; -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - zero = (*((const Tcl_WideInt *)ptr1) > (Tcl_WideInt)0); - break; -#endif - case TCL_NUMBER_BIG: - /* TODO: const correctness ? */ - zero = (mp_cmp_d((mp_int *)ptr1, 0) == MP_GT); - break; - default: - /* Unused, here to silence compiler warning. */ - zero = 0; - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(zero ? 0 : -1)); - return TCL_OK; - } - - shift = (int)(*((const long *)ptr2)); - /* Handle shifts within the native long range */ - if (type1 == TCL_NUMBER_LONG) { - l1 = *((const long *)ptr1); - if ((size_t)shift >= CHAR_BIT*sizeof(long)) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(l1 >= (long)0 ? 0 : -1)); - } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(l1 >> shift)); - } - return TCL_OK; - } - -#ifndef NO_WIDE_TYPE - /* Handle shifts within the native wide range */ - if (type1 == TCL_NUMBER_WIDE) { - Tcl_WideInt w = *((const Tcl_WideInt *)ptr1); - if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) { - Tcl_SetObjResult(interp, - Tcl_NewIntObj(w >= (Tcl_WideInt)0 ? 0 : -1)); - } else { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(w >> shift)); - } - return TCL_OK; - } -#endif - - { - mp_int big, bigResult, bigRemainder; - - Tcl_TakeBignumFromObj(NULL, objv[1], &big); - - mp_init(&bigResult); - mp_init(&bigRemainder); - mp_div_2d(&big, shift, &bigResult, &bigRemainder); - if (mp_cmp_d(&bigRemainder, 0) == MP_LT) { - /* Convert to Tcl's integer division rules */ - mp_sub_d(&bigResult, 1, &bigResult); - } - mp_clear(&bigRemainder); - mp_clear(&big); - - if (!Tcl_IsShared(objv[1])) { - Tcl_SetBignumObj(objv[1], &bigResult); - Tcl_SetObjResult(interp, objv[1]); - } else { - Tcl_SetObjResult(interp, Tcl_NewBignumObj(&bigResult)); - } - } - return TCL_OK; - - illegalOperand: - if (TclGetNumberFromObj(NULL, objv[idx], &ptr1, &type1) != TCL_OK) { - int numBytes; - const char *bytes = Tcl_GetStringFromObj(objv[idx], &numBytes); - if (numBytes == 0) { - description = "empty string"; - } else if (TclCheckBadOctal(NULL, bytes)) { - description = "invalid octal number"; - } else { - description = "non-numeric string"; - } - } else if (type1 == TCL_NUMBER_NAN) { - description = "non-numeric floating-point value"; - } else { - description = "floating-point value"; - } - - Tcl_SetObjResult(interp, - Tcl_ObjPrintf("can't use %s as operand of \">>\"", description)); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * TclModOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::%" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclModOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *argObj; - ClientData ptr1, ptr2; - int type1, type2; - long l1, l2 = 0; - const char *description; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "value value"); - return TCL_ERROR; - } - - if ((TclGetNumberFromObj(NULL, objv[1], &ptr1, &type1) != TCL_OK) - || (type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { - argObj = objv[1]; - goto badArg; - } - if ((TclGetNumberFromObj(NULL, objv[2], &ptr2, &type2) != TCL_OK) - || (type2 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_NAN)) { - argObj = objv[2]; - goto badArg; - } - - if (type2 == TCL_NUMBER_LONG) { - l2 = *((CONST long *)ptr2); - if (l2 == 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); - Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", - NULL); - return TCL_ERROR; - } - if ((l2 == 1) || (l2 == -1)) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); - return TCL_OK; - } - } - if (type1 == TCL_NUMBER_LONG) { - l1 = *((CONST long *)ptr1); - if (l1 == 0) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); - return TCL_OK; - } - if (type2 == TCL_NUMBER_LONG) { - /* Both operands are long; do native calculation */ - long lRemainder, lQuotient = l1 / l2; - - /* Force Tcl's integer division rules */ - /* TODO: examine for logic simplification */ - if (((lQuotient < 0) || ((lQuotient == 0) && - ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) && - ((lQuotient * l2) != l1)) { - lQuotient -= 1; - } - lRemainder = l1 - l2*lQuotient; - Tcl_SetLongObj(Tcl_GetObjResult(interp), lRemainder); - return TCL_OK; - } - /* - * First operand fits in long; second does not, so the second has - * greater magnitude than first. No need to divide to determine the - * remainder. - */ -#ifndef NO_WIDE_TYPE - if (type2 == TCL_NUMBER_WIDE) { - Tcl_WideInt w2 = *((CONST Tcl_WideInt *)ptr2); - - if ((l1 > 0) ^ (w2 > (Tcl_WideInt)0)) { - /* Arguments are opposite sign; remainder is sum */ - Tcl_SetObjResult(interp, - Tcl_NewWideIntObj(w2+(Tcl_WideInt)l1)); - return TCL_OK; - } - /* Arguments are same sign; remainder is first operand */ - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; - } -#endif - { - mp_int big2; - Tcl_TakeBignumFromObj(NULL, objv[2], &big2); - - /* TODO: internals intrusion */ - if ((l1 > 0) ^ (big2.sign == MP_ZPOS)) { - /* Arguments are opposite sign; remainder is sum */ - mp_int big1; - TclBNInitBignumFromLong(&big1, l1); - mp_add(&big2, &big1, &big2); - Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big2)); - } else { - /* Arguments are same sign; remainder is first operand */ - Tcl_SetObjResult(interp, objv[1]); - /* TODO: free big2? */ - } - } - return TCL_OK; - } -#ifndef NO_WIDE_TYPE - if (type1 == TCL_NUMBER_WIDE) { - Tcl_WideInt w1 = *((CONST Tcl_WideInt *)ptr1); - if (type2 != TCL_NUMBER_BIG) { - Tcl_WideInt w2, wQuotient, wRemainder; - - Tcl_GetWideIntFromObj(NULL, objv[2], &w2); - wQuotient = w1 / w2; - - /* Force Tcl's integer division rules */ - /* TODO: examine for logic simplification */ - if (((wQuotient < ((Tcl_WideInt) 0)) - || ((wQuotient == ((Tcl_WideInt) 0)) && ( - (w1 < ((Tcl_WideInt) 0) && w2 > ((Tcl_WideInt) 0)) - || (w1 > ((Tcl_WideInt) 0) && w2 < ((Tcl_WideInt) 0))) - )) && ((wQuotient * w2) != w1)) { - wQuotient -= (Tcl_WideInt) 1; - } - wRemainder = w1 - w2*wQuotient; - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wRemainder)); - } else { - mp_int big2; - Tcl_TakeBignumFromObj(NULL, objv[2], &big2); - - /* TODO: internals intrusion */ - if ((w1 > ((Tcl_WideInt) 0)) ^ (big2.sign == MP_ZPOS)) { - /* Arguments are opposite sign; remainder is sum */ - mp_int big1; - TclBNInitBignumFromWideInt(&big1, w1); - mp_add(&big2, &big1, &big2); - Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big2)); - } else { - /* Arguments are same sign; remainder is first operand */ - Tcl_SetObjResult(interp, objv[1]); - } - } - return TCL_OK; - } -#endif - { - mp_int big1, big2, bigResult, bigRemainder; - - Tcl_GetBignumFromObj(NULL, objv[1], &big1); - Tcl_GetBignumFromObj(NULL, objv[2], &big2); - mp_init(&bigResult); - mp_init(&bigRemainder); - mp_div(&big1, &big2, &bigResult, &bigRemainder); - if (!mp_iszero(&bigRemainder) && (bigRemainder.sign != big2.sign)) { - /* Convert to Tcl's integer division rules */ - mp_sub_d(&bigResult, 1, &bigResult); - mp_add(&bigRemainder, &big2, &bigRemainder); - } - mp_copy(&bigRemainder, &bigResult); - mp_clear(&bigRemainder); - mp_clear(&big1); - mp_clear(&big2); - if (Tcl_IsShared(objv[1])) { - Tcl_SetObjResult(interp, Tcl_NewBignumObj(&bigResult)); - } else { - Tcl_SetBignumObj(objv[1], &bigResult); - Tcl_SetObjResult(interp, objv[1]); - } - return TCL_OK; - } - - badArg: - if (TclGetNumberFromObj(NULL, argObj, &ptr1, &type1) != TCL_OK) { - int numBytes; - CONST char *bytes = Tcl_GetStringFromObj(argObj, &numBytes); - if (numBytes == 0) { - description = "empty string"; - } else if (TclCheckBadOctal(NULL, bytes)) { - description = "invalid octal number"; - } else { - description = "non-numeric string"; - } - } else if (type1 == TCL_NUMBER_NAN) { - description = "non-numeric floating-point value"; - } else { - description = "floating-point value"; - } - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use %s as operand of \"%%\"", description)); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * TclNeqOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::!=" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclNeqOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - int result = 1, cmp, len1, len2; - const char *str1, *str2; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "value value"); - return TCL_ERROR; - } - - switch (CompareNumbers(NULL, objv[1], objv[2], &cmp)) { - case TCL_ERROR: - /* - * Got a string - */ - str1 = Tcl_GetStringFromObj(objv[1], &len1); - str2 = Tcl_GetStringFromObj(objv[2], &len2); - if (len1 == len2 && !strcmp(str1, str2)) { - result = 0; - } - case TCL_BREAK: /* Deliberate fallthrough */ - break; - case TCL_OK: - /* - * Got proper numbers - */ - if (cmp == MP_EQ) { - result = 0; - } - } - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), result); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclStrneqOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::ne" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclStrneqOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - const char *s1, *s2; - int s1len, s2len; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "value value"); - return TCL_ERROR; - } - - s1 = Tcl_GetStringFromObj(objv[1], &s1len); - s2 = Tcl_GetStringFromObj(objv[2], &s2len); - if (s1len == s2len && !strcmp(s1, s2)) { - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 0); - } else { - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 1); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclInOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::in" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclInOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - const char *s1, *s2; - int s1len, s2len, i, len; - Tcl_Obj **listObj; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "value list"); - return TCL_ERROR; - } - - if (Tcl_ListObjGetElements(interp, objv[2], &len, &listObj) != TCL_OK) { - return TCL_ERROR; - } - s1 = Tcl_GetStringFromObj(objv[1], &s1len); - for (i=0 ; i<len ; i++) { - s2 = Tcl_GetStringFromObj(listObj[i], &s2len); - if (s1len == s2len && !strcmp(s1, s2)) { - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 1); - return TCL_OK; - } - } - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 0); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclNiOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::ni" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclNiOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - const char *s1, *s2; - int s1len, s2len, i, len; - Tcl_Obj **listObj; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "value list"); - return TCL_ERROR; - } - - if (Tcl_ListObjGetElements(interp, objv[2], &len, &listObj) != TCL_OK) { - return TCL_ERROR; - } - s1 = Tcl_GetStringFromObj(objv[1], &s1len); - for (i=0 ; i<len ; i++) { - s2 = Tcl_GetStringFromObj(listObj[i], &s2len); - if (s1len == s2len && !strcmp(s1, s2)) { - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 0); - return TCL_OK; - } - } - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 1); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclLessOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::<" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclLessOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - int result = 1; - - if (objc > 2) { - int i, cmp, len1, len2; - const char *str1, *str2; - - for (i=1 ; i<objc-1 ; i++) { - switch (CompareNumbers(NULL, objv[i], objv[i+1], &cmp)) { - case TCL_ERROR: - /* - * Got a string - */ - str1 = Tcl_GetStringFromObj(objv[i], &len1); - str2 = Tcl_GetStringFromObj(objv[i+1], &len2); - if (TclpUtfNcmp2(str1, str2, - (size_t) ((len1 < len2) ? len1 : len2)) >= 0) { - result = 0; - i = objc; - } - continue; - case TCL_OK: - /* - * Got proper numbers - */ - if (cmp != MP_LT) { - result = 0; - i = objc; - } - continue; - case TCL_BREAK: - /* - * Got a NaN (which is different from everything, including - * itself) - */ - result = 0; - i = objc; - continue; - } - } - } - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), result); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclLeqOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::<=" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclLeqOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - int result = 1; - - if (objc > 2) { - int i, cmp, len1, len2; - const char *str1, *str2; - - for (i=1 ; i<objc-1 ; i++) { - switch (CompareNumbers(NULL, objv[i], objv[i+1], &cmp)) { - case TCL_ERROR: - /* - * Got a string - */ - str1 = Tcl_GetStringFromObj(objv[i], &len1); - str2 = Tcl_GetStringFromObj(objv[i+1], &len2); - if (TclpUtfNcmp2(str1, str2, - (size_t) ((len1 < len2) ? len1 : len2)) > 0) { - result = 0; - i = objc; - } - continue; - case TCL_OK: - /* - * Got proper numbers - */ - if (cmp == MP_GT) { - result = 0; - i = objc; - } - continue; - case TCL_BREAK: - /* - * Got a NaN (which is different from everything, including - * itself) - */ - result = 0; - i = objc; - continue; - } - } - } - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), result); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclGreaterOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::>" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclGreaterOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - int result = 1; - - if (objc > 2) { - int i, cmp, len1, len2; - const char *str1, *str2; - - for (i=1 ; i<objc-1 ; i++) { - switch (CompareNumbers(NULL, objv[i], objv[i+1], &cmp)) { - case TCL_ERROR: - /* - * Got a string - */ - str1 = Tcl_GetStringFromObj(objv[i], &len1); - str2 = Tcl_GetStringFromObj(objv[i+1], &len2); - if (TclpUtfNcmp2(str1, str2, - (size_t) ((len1 < len2) ? len1 : len2)) <= 0) { - result = 0; - i = objc; - } - continue; - case TCL_OK: - /* - * Got proper numbers - */ - if (cmp != MP_GT) { - result = 0; - i = objc; - } - continue; - case TCL_BREAK: - /* - * Got a NaN (which is different from everything, including - * itself) - */ - result = 0; - i = objc; - continue; - } - } - } - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), result); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclGeqOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::>=" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclGeqOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - int result = 1; - - if (objc > 2) { - int i, cmp, len1, len2; - const char *str1, *str2; - - for (i=1 ; i<objc-1 ; i++) { - switch (CompareNumbers(NULL, objv[i], objv[i+1], &cmp)) { - case TCL_ERROR: - /* - * Got a string - */ - str1 = Tcl_GetStringFromObj(objv[i], &len1); - str2 = Tcl_GetStringFromObj(objv[i+1], &len2); - if (TclpUtfNcmp2(str1, str2, - (size_t) ((len1 < len2) ? len1 : len2)) < 0) { - result = 0; - i = objc; - } - continue; - case TCL_OK: - /* - * Got proper numbers - */ - if (cmp == MP_LT) { - result = 0; - i = objc; - } - continue; - case TCL_BREAK: - /* - * Got a NaN (which is different from everything, including - * itself) - */ - result = 0; - i = objc; - continue; - } - } - } - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), result); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclEqOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::==" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclEqOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - int result = 1; - - if (objc > 2) { - int i, cmp, len1, len2; - const char *str1, *str2; - - for (i=1 ; i<objc-1 ; i++) { - switch (CompareNumbers(NULL, objv[i], objv[i+1], &cmp)) { - case TCL_ERROR: - /* - * Got a string - */ - str1 = Tcl_GetStringFromObj(objv[i], &len1); - str2 = Tcl_GetStringFromObj(objv[i+1], &len2); - if (len1 != len2 || strcmp(str1, str2)) { - result = 0; - i = objc; - } - continue; - case TCL_OK: - /* - * Got proper numbers - */ - if (cmp != MP_EQ) { - result = 0; - i = objc; - } - continue; - case TCL_BREAK: - /* - * Got a NaN (which is different from everything, including - * itself) - */ - result = 0; - i = objc; - continue; - } - } - } - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), result); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclStreqOpCmd -- - * - * This procedure is invoked to process the "::tcl::mathop::eq" Tcl - * command. See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclStreqOpCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - int result = 1; - - if (objc > 2) { - int i, len1, len2; - const char *str1, *str2; - - for (i=1 ; i<objc-1 ; i++) { - str1 = Tcl_GetStringFromObj(objv[i], &len1); - str2 = Tcl_GetStringFromObj(objv[i+1], &len2); - if (len1 != len2 || strcmp(str1, str2)) { - result = 0; - break; - } - } - } - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), result); - return TCL_OK; -} -#endif - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ |