summaryrefslogtreecommitdiffstats
path: root/generic/tclMathOp.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclMathOp.c')
-rw-r--r--generic/tclMathOp.c2884
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:
- */