/* * 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 #include /* * 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 # else /* NO_FLOAT_H */ # ifndef NO_VALUES_H # include # 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=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 (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<0) ? w : ~w) & -(((Tcl_WideInt)1) << (CHAR_BIT*sizeof(Tcl_WideInt)-1-shift)))) { Tcl_SetObjResult(interp, Tcl_NewWideIntObj(w<>" 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 2) { int i, cmp, len1, len2; const char *str1, *str2; for (i=1 ; i= 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 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=" 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 2) { int i, cmp, len1, len2; const char *str1, *str2; for (i=1 ; i 2) { int i, len1, len2; const char *str1, *str2; for (i=1 ; i