Attachment "tip174.patch" to
ticket [1578137fff]
added by
pspjuth
2006-12-07 21:22:06.
diff -ru ../tcl-20061206/generic/tclBasic.c ./generic/tclBasic.c
--- ../tcl-20061206/generic/tclBasic.c 2006-12-06 08:02:56.000000000 +0100
+++ ./generic/tclBasic.c 2006-12-07 14:32:13.000000000 +0100
@@ -271,30 +271,30 @@
*/
static const CmdInfo mathOpCmds[] = {
- { "::tcl::mathop::~", TclInvertOpCmd, TclCompileInvertOpCmd, 1 },
- { "::tcl::mathop::!", TclNotOpCmd, TclCompileNotOpCmd, 1 },
- { "::tcl::mathop::+", TclAddOpCmd, TclCompileAddOpCmd, 1 },
- { "::tcl::mathop::*", TclMulOpCmd, TclCompileMulOpCmd, 1 },
- { "::tcl::mathop::&", TclAndOpCmd, TclCompileAndOpCmd, 1 },
- { "::tcl::mathop::|", TclOrOpCmd, TclCompileOrOpCmd, 1 },
- { "::tcl::mathop::^", TclXorOpCmd, TclCompileXorOpCmd, 1 },
- { "::tcl::mathop::**", TclPowOpCmd, TclCompilePowOpCmd, 1 },
- { "::tcl::mathop::<<", TclLshiftOpCmd, TclCompileLshiftOpCmd, 1 },
- { "::tcl::mathop::>>", TclRshiftOpCmd, TclCompileRshiftOpCmd, 1 },
- { "::tcl::mathop::%", TclModOpCmd, TclCompileModOpCmd, 1 },
- { "::tcl::mathop::!=", TclNeqOpCmd, TclCompileNeqOpCmd, 1 },
- { "::tcl::mathop::ne", TclStrneqOpCmd, TclCompileStrneqOpCmd, 1 },
- { "::tcl::mathop::in", TclInOpCmd, TclCompileInOpCmd, 1 },
- { "::tcl::mathop::ni", TclNiOpCmd, TclCompileNiOpCmd, 1 },
- { "::tcl::mathop::-", TclMinusOpCmd, TclCompileMinusOpCmd, 1 },
- { "::tcl::mathop::/", TclDivOpCmd, TclCompileDivOpCmd, 1 },
- { "::tcl::mathop::<", TclLessOpCmd, TclCompileLessOpCmd, 1 },
- { "::tcl::mathop::<=", TclLeqOpCmd, TclCompileLeqOpCmd, 1 },
- { "::tcl::mathop::>", TclGreaterOpCmd,TclCompileGreaterOpCmd,1 },
- { "::tcl::mathop::>=", TclGeqOpCmd, TclCompileGeqOpCmd, 1 },
- { "::tcl::mathop::==", TclEqOpCmd, TclCompileEqOpCmd, 1 },
- { "::tcl::mathop::eq", TclStreqOpCmd, TclCompileStreqOpCmd, 1 },
- { NULL, NULL, NULL, 0 }
+ { "~", TclInvertOpCmd, TclCompileInvertOpCmd, 1 },
+ { "!", TclNotOpCmd, TclCompileNotOpCmd, 1 },
+ { "+", TclAddOpCmd, TclCompileAddOpCmd, 1 },
+ { "*", TclMulOpCmd, TclCompileMulOpCmd, 1 },
+ { "&", TclAndOpCmd, TclCompileAndOpCmd, 1 },
+ { "|", TclOrOpCmd, TclCompileOrOpCmd, 1 },
+ { "^", TclXorOpCmd, TclCompileXorOpCmd, 1 },
+ { "**", TclPowOpCmd, TclCompilePowOpCmd, 1 },
+ { "<<", TclLshiftOpCmd, TclCompileLshiftOpCmd, 1 },
+ { ">>", TclRshiftOpCmd, TclCompileRshiftOpCmd, 1 },
+ { "%", TclModOpCmd, TclCompileModOpCmd, 1 },
+ { "!=", TclNeqOpCmd, TclCompileNeqOpCmd, 1 },
+ { "ne", TclStrneqOpCmd, TclCompileStrneqOpCmd, 1 },
+ { "in", TclInOpCmd, TclCompileInOpCmd, 1 },
+ { "ni", TclNiOpCmd, TclCompileNiOpCmd, 1 },
+ { "-", TclMinusOpCmd, TclCompileMinusOpCmd, 1 },
+ { "/", TclDivOpCmd, TclCompileDivOpCmd, 1 },
+ { "<", TclLessOpCmd, TclCompileLessOpCmd, 1 },
+ { "<=", TclLeqOpCmd, TclCompileLeqOpCmd, 1 },
+ { ">", TclGreaterOpCmd, TclCompileGreaterOpCmd, 1 },
+ { ">=", TclGeqOpCmd, TclCompileGeqOpCmd, 1 },
+ { "==", TclEqOpCmd, TclCompileEqOpCmd, 1 },
+ { "eq", TclStreqOpCmd, TclCompileStreqOpCmd, 1 },
+ { NULL, NULL, NULL, 0 }
};
/*
@@ -324,7 +324,7 @@
const BuiltinFuncDef *builtinFuncPtr;
const CmdInfo *cmdInfoPtr;
const CmdInfo2 *cmdInfo2Ptr;
- Tcl_Namespace *mathfuncNSPtr;
+ Tcl_Namespace *mathfuncNSPtr, *mathopNSPtr;
union {
char c[sizeof(short)];
short s;
@@ -626,17 +626,22 @@
* Register the mathematical "operator" commands. [TIP #174]
*/
- if (Tcl_CreateNamespace(interp, "::tcl::mathop", NULL, NULL) == NULL) {
+ mathopNSPtr = Tcl_CreateNamespace(interp, "::tcl::mathop", NULL, NULL);
+#define MATH_OP_PREFIX_LEN 15 /* == strlen("::tcl::mathop::") */
+ if (mathopNSPtr == NULL) {
Tcl_Panic("can't create math operator namespace");
}
+ strcpy(mathFuncName, "::tcl::mathop::");
for (cmdInfoPtr=mathOpCmds ; cmdInfoPtr->name!=NULL ; cmdInfoPtr++) {
- cmdPtr = (Command *) Tcl_CreateObjCommand(interp, cmdInfoPtr->name,
+ strcpy(mathFuncName + MATH_OP_PREFIX_LEN, cmdInfoPtr->name);
+ cmdPtr = (Command *) Tcl_CreateObjCommand(interp, mathFuncName,
cmdInfoPtr->objProc, NULL, NULL);
if (cmdPtr == NULL) {
Tcl_Panic("failed to create math operator %s", cmdInfoPtr->name);
} else if (cmdInfoPtr->compileProc != NULL) {
cmdPtr->compileProc = cmdInfoPtr->compileProc;
}
+ Tcl_Export(interp, mathopNSPtr, cmdInfoPtr->name, 0);
}
/*
diff -ru ../tcl-20061206/generic/tclCmdMZ.c ./generic/tclCmdMZ.c
--- ../tcl-20061206/generic/tclCmdMZ.c 2006-11-29 08:02:49.000000000 +0100
+++ ./generic/tclCmdMZ.c 2006-12-07 14:32:58.000000000 +0100
@@ -1166,9 +1166,7 @@
* INST_EQ/INST_NEQ/INST_LT/...).
*/
- int i, match, length, nocase = 0, reqlength = -1;
- typedef int (*strCmpFn_t)(const char *, const char *, unsigned int);
- strCmpFn_t strCmpFn;
+ int i, match, nocase = 0, reqlength = -1;
if (objc < 4 || objc > 7) {
str_cmp_args:
@@ -1205,87 +1203,13 @@
objv += objc-2;
- if ((reqlength == 0) || (objv[0] == objv[1])) {
- /*
- * Always match at 0 chars of if it is the same obj.
- */
-
- Tcl_SetObjResult(interp,
- Tcl_NewBooleanObj((enum options) index == STR_EQUAL));
- break;
- } else if (!nocase && objv[0]->typePtr == &tclByteArrayType &&
- objv[1]->typePtr == &tclByteArrayType) {
- /*
- * Use binary versions of comparisons since that won't cause undue
- * type conversions and it is much faster. Only do this if we're
- * case-sensitive (which is all that really makes sense with byte
- * arrays anyway, and we have no memcasecmp() for some
- * reason... :^)
- */
-
- string1 = (char *) Tcl_GetByteArrayFromObj(objv[0], &length1);
- string2 = (char *) Tcl_GetByteArrayFromObj(objv[1], &length2);
- strCmpFn = (strCmpFn_t) memcmp;
- } else if ((objv[0]->typePtr == &tclStringType)
- && (objv[1]->typePtr == &tclStringType)) {
- /*
- * Do a unicode-specific comparison if both of the args are of
- * String type. In benchmark testing this proved the most
- * efficient check between the unicode and string comparison
- * operations.
- */
-
- string1 = (char *) Tcl_GetUnicodeFromObj(objv[0], &length1);
- string2 = (char *) Tcl_GetUnicodeFromObj(objv[1], &length2);
- strCmpFn = (strCmpFn_t)
- (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp);
- } else {
- /*
- * As a catch-all we will work with UTF-8. We cannot use memcmp()
- * as that is unsafe with any string containing NULL (\xC0\x80 in
- * Tcl's utf rep). We can use the more efficient TclpUtfNcmp2 if
- * we are case-sensitive and no specific length was requested.
- */
-
- string1 = (char *) Tcl_GetStringFromObj(objv[0], &length1);
- string2 = (char *) Tcl_GetStringFromObj(objv[1], &length2);
- if ((reqlength < 0) && !nocase) {
- strCmpFn = (strCmpFn_t) TclpUtfNcmp2;
- } else {
- length1 = Tcl_NumUtfChars(string1, length1);
- length2 = Tcl_NumUtfChars(string2, length2);
- strCmpFn = (strCmpFn_t)
- (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp);
- }
- }
-
- if (((enum options) index == STR_EQUAL)
- && (reqlength < 0) && (length1 != length2)) {
- match = 1; /* this will be reversed below */
- } else {
- length = (length1 < length2) ? length1 : length2;
- if (reqlength > 0 && reqlength < length) {
- length = reqlength;
- } else if (reqlength < 0) {
- /*
- * The requested length is negative, so we ignore it by
- * setting it to length + 1 so we correct the match var.
- */
-
- reqlength = length + 1;
- }
-
- match = strCmpFn(string1, string2, (unsigned) length);
- if ((match == 0) && (reqlength > length)) {
- match = length1 - length2;
- }
- }
+ match = TclStrCompare(objv[0], objv[1], nocase, reqlength,
+ (enum options) index == STR_EQUAL);
if ((enum options) index == STR_EQUAL) {
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1));
} else {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(
- (match > 0) ? 1 : (match < 0) ? -1 : 0));
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(match));
}
break;
}
diff -ru ../tcl-20061206/generic/tclCompCmds.c ./generic/tclCompCmds.c
--- ../tcl-20061206/generic/tclCompCmds.c 2006-12-07 12:59:13.000000000 +0100
+++ ./generic/tclCompCmds.c 2006-12-07 14:29:01.000000000 +0100
@@ -138,6 +138,12 @@
static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, CONST char *identity,
unsigned char instruction, CompileEnv *envPtr);
+static int CompileCompOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, unsigned char instruction,
+ CompileEnv *envPtr);
+static int CompileStrictlyBinaryOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, unsigned char instruction,
+ CompileEnv *envPtr);
static int CompileUnaryOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, unsigned char instruction,
CompileEnv *envPtr);
@@ -4658,6 +4664,12 @@
if (parsePtr->numWords == 1) {
PushLiteral(envPtr, identity, -1);
return TCL_OK;
+ } else if (parsePtr->numWords == 2) {
+ /*
+ * Defer single argument to runtime for content checking.
+ */
+
+ return TCL_ERROR;
}
for (words=1 ; words<parsePtr->numWords ; words++) {
tokenPtr = TokenAfter(tokenPtr);
@@ -4705,6 +4717,88 @@
/*
*----------------------------------------------------------------------
*
+ * CompileCompOpCmd --
+ *
+ * Helper to compile comparison math operators
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileCompOpCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ unsigned char instruction, /* BC instruction for operator */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr;
+ DefineLineInformation; /* TIP #280 */
+
+ if (parsePtr->numWords < 3) {
+ /*
+ * Zero or one argument is always true.
+ * Discard single argument.
+ */
+
+ if (parsePtr->numWords == 2) {
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ TclEmitOpcode(INST_POP, envPtr);
+ }
+ PushLiteral(envPtr, "1", 1);
+ return TCL_OK;
+ } else if (parsePtr->numWords == 3) {
+ /*
+ * Two arguments is just like a binary operator.
+ */
+
+ return CompileAssociativeBinaryOpCmd(interp, parsePtr,
+ NULL, instruction, envPtr);
+ } else if (envPtr->procPtr == NULL) {
+ /*
+ * No local variable space, which is needed for >= 3 args!
+ */
+
+ return TCL_ERROR;
+ } else {
+ int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, VAR_SCALAR,
+ envPtr->procPtr);
+ int words;
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
+ TclEmitOpcode(instruction, envPtr);
+ for (words=3 ; words<parsePtr->numWords ;) {
+ TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr);
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, words);
+ if (++words < parsePtr->numWords) {
+ TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
+ }
+ TclEmitOpcode(instruction, envPtr);
+ }
+ for (; words>3 ; words--) {
+ TclEmitOpcode(INST_BITAND, envPtr);
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompile*OpCmd --
*
* Procedures called to compile the corresponding
@@ -4823,8 +4917,6 @@
* in reverse order and apply a different sequence of instructions.
* For N arguments, we apply N-2 INST_ADDs, then one INST_SUB.
* Note that this does the right thing for N=2, a single INST_SUB.
- * When N=1, we can add a phony leading "0" argument and get the
- * right result from the same algorithm as well.
*/
int
@@ -4841,7 +4933,10 @@
return TCL_ERROR;
}
if (parsePtr->numWords == 2) {
- PushLiteral(envPtr, "0", -1);
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ TclEmitOpcode(INST_UMINUS, envPtr);
+ return TCL_OK;
}
for (words=1 ; words<parsePtr->numWords ; words++) {
tokenPtr = TokenAfter(tokenPtr);
@@ -4875,6 +4970,12 @@
CompileWord(envPtr, tokenPtr, interp,1);
TclEmitOpcode(INST_DIV, envPtr);
return TCL_OK;
+ } else if (parsePtr->numWords > 3) {
+ /*
+ * Defer more than two args to runtime to get correct behaviour.
+ */
+
+ return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp,1);
@@ -4956,48 +5057,7 @@
Tcl_Parse *parsePtr,
CompileEnv *envPtr)
{
- Tcl_Token *tokenPtr;
- DefineLineInformation; /* TIP #280 */
-
- if (parsePtr->numWords < 3) {
- PushLiteral(envPtr, "1", 1);
- } else if (parsePtr->numWords == 3) {
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,1);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,2);
- TclEmitOpcode(INST_LT, envPtr);
- } else if (envPtr->procPtr == NULL) {
- /*
- * No local variable space!
- */
-
- return TCL_ERROR;
- } else {
- int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, VAR_SCALAR,
- envPtr->procPtr);
- int words;
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,1);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,2);
- TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
- TclEmitOpcode(INST_LT, envPtr);
- for (words=3 ; words<parsePtr->numWords ;) {
- TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, words);
- if (++words < parsePtr->numWords) {
- TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
- }
- TclEmitOpcode(INST_LT, envPtr);
- }
- for (; words>3 ; words--) {
- TclEmitOpcode(INST_BITAND, envPtr);
- }
- }
- return TCL_OK;
+ return CompileCompOpCmd(interp, parsePtr, INST_LT, envPtr);
}
int
@@ -5006,48 +5066,7 @@
Tcl_Parse *parsePtr,
CompileEnv *envPtr)
{
- Tcl_Token *tokenPtr;
- DefineLineInformation; /* TIP #280 */
-
- if (parsePtr->numWords < 3) {
- PushLiteral(envPtr, "1", 1);
- } else if (parsePtr->numWords == 3) {
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,1);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,2);
- TclEmitOpcode(INST_LE, envPtr);
- } else if (envPtr->procPtr == NULL) {
- /*
- * No local variable space!
- */
-
- return TCL_ERROR;
- } else {
- int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, VAR_SCALAR,
- envPtr->procPtr);
- int words;
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,1);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,2);
- TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
- TclEmitOpcode(INST_LE, envPtr);
- for (words=3 ; words<parsePtr->numWords ;) {
- TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,words);
- if (++words < parsePtr->numWords) {
- TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
- }
- TclEmitOpcode(INST_LE, envPtr);
- }
- for (; words>3 ; words--) {
- TclEmitOpcode(INST_BITAND, envPtr);
- }
- }
- return TCL_OK;
+ return CompileCompOpCmd(interp, parsePtr, INST_LE, envPtr);
}
int
@@ -5056,48 +5075,7 @@
Tcl_Parse *parsePtr,
CompileEnv *envPtr)
{
- Tcl_Token *tokenPtr;
- DefineLineInformation; /* TIP #280 */
-
- if (parsePtr->numWords < 3) {
- PushLiteral(envPtr, "1", 1);
- } else if (parsePtr->numWords == 3) {
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,1);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,2);
- TclEmitOpcode(INST_GT, envPtr);
- } else if (envPtr->procPtr == NULL) {
- /*
- * No local variable space!
- */
-
- return TCL_ERROR;
- } else {
- int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, VAR_SCALAR,
- envPtr->procPtr);
- int words;
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,1);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,2);
- TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
- TclEmitOpcode(INST_GT, envPtr);
- for (words=3 ; words<parsePtr->numWords ;) {
- TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,words);
- if (++words < parsePtr->numWords) {
- TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
- }
- TclEmitOpcode(INST_GT, envPtr);
- }
- for (; words>3 ; words--) {
- TclEmitOpcode(INST_BITAND, envPtr);
- }
- }
- return TCL_OK;
+ return CompileCompOpCmd(interp, parsePtr, INST_GT, envPtr);
}
int
@@ -5106,48 +5084,7 @@
Tcl_Parse *parsePtr,
CompileEnv *envPtr)
{
- Tcl_Token *tokenPtr;
- DefineLineInformation; /* TIP #280 */
-
- if (parsePtr->numWords < 3) {
- PushLiteral(envPtr, "1", 1);
- } else if (parsePtr->numWords == 3) {
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,1);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,2);
- TclEmitOpcode(INST_GE, envPtr);
- } else if (envPtr->procPtr == NULL) {
- /*
- * No local variable space!
- */
-
- return TCL_ERROR;
- } else {
- int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, VAR_SCALAR,
- envPtr->procPtr);
- int words;
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,1);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,2);
- TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
- TclEmitOpcode(INST_GE, envPtr);
- for (words=3 ; words<parsePtr->numWords ;) {
- TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, words);
- if (++words < parsePtr->numWords) {
- TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
- }
- TclEmitOpcode(INST_GE, envPtr);
- }
- for (; words>3 ; words--) {
- TclEmitOpcode(INST_BITAND, envPtr);
- }
- }
- return TCL_OK;
+ return CompileCompOpCmd(interp, parsePtr, INST_GE, envPtr);
}
int
@@ -5156,48 +5093,7 @@
Tcl_Parse *parsePtr,
CompileEnv *envPtr)
{
- Tcl_Token *tokenPtr;
- DefineLineInformation; /* TIP #280 */
-
- if (parsePtr->numWords < 3) {
- PushLiteral(envPtr, "1", 1);
- } else if (parsePtr->numWords == 3) {
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,1);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,2);
- TclEmitOpcode(INST_EQ, envPtr);
- } else if (envPtr->procPtr == NULL) {
- /*
- * No local variable space!
- */
-
- return TCL_ERROR;
- } else {
- int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, VAR_SCALAR,
- envPtr->procPtr);
- int words;
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,1);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,2);
- TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
- TclEmitOpcode(INST_EQ, envPtr);
- for (words=3 ; words<parsePtr->numWords ;) {
- TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, words);
- if (++words < parsePtr->numWords) {
- TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
- }
- TclEmitOpcode(INST_EQ, envPtr);
- }
- for (; words>3 ; words--) {
- TclEmitOpcode(INST_BITAND, envPtr);
- }
- }
- return TCL_OK;
+ return CompileCompOpCmd(interp, parsePtr, INST_EQ, envPtr);
}
int
@@ -5206,48 +5102,7 @@
Tcl_Parse *parsePtr,
CompileEnv *envPtr)
{
- Tcl_Token *tokenPtr;
- DefineLineInformation; /* TIP #280 */
-
- if (parsePtr->numWords < 3) {
- PushLiteral(envPtr, "1", 1);
- } else if (parsePtr->numWords == 3) {
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,1);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,2);
- TclEmitOpcode(INST_STR_EQ, envPtr);
- } else if (envPtr->procPtr == NULL) {
- /*
- * No local variable space!
- */
-
- return TCL_ERROR;
- } else {
- int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, VAR_SCALAR,
- envPtr->procPtr);
- int words;
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,1);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp,2);
- TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
- TclEmitOpcode(INST_STR_EQ, envPtr);
- for (words=3 ; words<parsePtr->numWords ;) {
- TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr);
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, words);
- if (++words < parsePtr->numWords) {
- TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
- }
- TclEmitOpcode(INST_STR_EQ, envPtr);
- }
- for (; words>3 ; words--) {
- TclEmitOpcode(INST_BITAND, envPtr);
- }
- }
- return TCL_OK;
+ return CompileCompOpCmd(interp, parsePtr, INST_STR_EQ, envPtr);
}
/*
diff -ru ../tcl-20061206/generic/tclExecute.c ./generic/tclExecute.c
--- ../tcl-20061206/generic/tclExecute.c 2006-12-02 08:03:11.000000000 +0100
+++ ./generic/tclExecute.c 2006-12-07 13:26:44.000000000 +0100
@@ -3145,36 +3145,10 @@
value2Ptr = *tosPtr;
valuePtr = *(tosPtr - 1);
- if (valuePtr == value2Ptr) {
- /*
- * On the off-chance that the objects are the same, we don't
- * really have to think hard about equality.
- */
-
- iResult = (*pc == INST_STR_EQ);
- } else {
- char *s1, *s2;
- int s1len, s2len;
-
- s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
- s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
- if (s1len == s2len) {
- /*
- * We only need to check (in)equality when we have equal
- * length strings.
- */
-
- if (*pc == INST_STR_NEQ) {
- iResult = (strcmp(s1, s2) != 0);
- } else {
- /* INST_STR_EQ */
- iResult = (strcmp(s1, s2) == 0);
- }
- } else {
- iResult = (*pc == INST_STR_NEQ);
- }
+ iResult = TclStrCompare(valuePtr, value2Ptr, 0, -1, 1);
+ if (*pc == INST_STR_EQ) {
+ iResult = !iResult;
}
-
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
/*
@@ -3203,69 +3177,14 @@
* String compare
*/
- CONST char *s1, *s2;
- int s1len, s2len, iResult;
+ int iResult;
Tcl_Obj *valuePtr, *value2Ptr;
stringCompare:
value2Ptr = *tosPtr;
valuePtr = *(tosPtr - 1);
- /*
- * The comparison function should compare up to the minimum byte
- * length only.
- */
-
- if (valuePtr == value2Ptr) {
- /*
- * In the pure equality case, set lengths too for the checks below
- * (or we could goto beyond it).
- */
-
- iResult = s1len = s2len = 0;
- } else if ((valuePtr->typePtr == &tclByteArrayType)
- && (value2Ptr->typePtr == &tclByteArrayType)) {
- s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len);
- s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
- iResult = memcmp(s1, s2,
- (size_t) ((s1len < s2len) ? s1len : s2len));
- } else if (((valuePtr->typePtr == &tclStringType)
- && (value2Ptr->typePtr == &tclStringType))) {
- /*
- * Do a unicode-specific comparison if both of the args are of
- * String type. If the char length == byte length, we can do a
- * memcmp. In benchmark testing this proved the most efficient
- * check between the unicode and string comparison operations.
- */
-
- s1len = Tcl_GetCharLength(valuePtr);
- s2len = Tcl_GetCharLength(value2Ptr);
- if ((s1len == valuePtr->length) && (s2len == value2Ptr->length)) {
- iResult = memcmp(valuePtr->bytes, value2Ptr->bytes,
- (unsigned) ((s1len < s2len) ? s1len : s2len));
- } else {
- iResult = TclUniCharNcmp(Tcl_GetUnicode(valuePtr),
- Tcl_GetUnicode(value2Ptr),
- (unsigned) ((s1len < s2len) ? s1len : s2len));
- }
- } else {
- /*
- * We can't do a simple memcmp in order to handle the special Tcl
- * \xC0\x80 null encoding for utf-8.
- */
- s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
- s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
- iResult = TclpUtfNcmp2(s1, s2,
- (size_t) ((s1len < s2len) ? s1len : s2len));
- }
-
- /*
- * Make sure only -1,0,1 is returned
- * TODO: consider peephole opt.
- */
- if (iResult == 0) {
- iResult = s1len - s2len;
- }
+ iResult = TclStrCompare(valuePtr, value2Ptr, 0, -1, 0);
if (*pc != INST_STR_CMP) {
/* Take care of the opcodes that goto'ed into here */
@@ -3942,7 +3861,12 @@
if (*pc == INST_LSHIFT) {
/* Large left shifts create integer overflow */
- result = Tcl_GetIntFromObj(NULL, value2Ptr, &shift);
+ if ((type2 != TCL_NUMBER_LONG) ||
+ (*((const long *)ptr2) > (long) INT_MAX)) {
+ result = TCL_ERROR;
+ } else {
+ result = Tcl_GetIntFromObj(NULL, value2Ptr, &shift);
+ }
if (result != TCL_OK) {
/*
* Technically, we could hold the value (1 << (INT_MAX+1)) in
@@ -4117,115 +4041,13 @@
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 (*pc) {
- 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;
- }
+ TclBitWiseBignumOp(*pc, &big1, &big2, &bigResult);
mp_clear(&big1);
mp_clear(&big2);
@@ -4786,6 +4608,7 @@
if (type2 == TCL_NUMBER_BIG) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("exponent too large", -1));
+ result = TCL_ERROR;
goto checkForCatch;
}
/* TODO: Perform those computations that fit in native types */
@@ -4821,7 +4644,7 @@
{
/* Must check for overflow */
if (((w1 < 0) && (w2 > 0) && (wResult > 0))
- || ((w1 > 0) && (w2 < 0) && (wResult < 0))) {
+ || ((w1 >= 0) && (w2 < 0) && (wResult < 0))) {
goto overflow;
}
}
@@ -4906,6 +4729,7 @@
Tcl_NewStringObj("exponent too large", -1));
mp_clear(&big1);
mp_clear(&big2);
+ result = TCL_ERROR;
goto checkForCatch;
}
mp_expt_d(&big1, big2.dp[0], &bigResult);
@@ -6368,6 +6192,169 @@
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't use %s as operand of \"%s\"", description, operator));
}
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclIllegalExprOperandType --
+ *
+ * Exported version of IllegalExprOperandType.
+ * Bytecode argument is provided by value instead of by pointer.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * An error message is appended to the interp result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclIllegalExprOperandType(
+ Tcl_Interp *interp, /* Interpreter to which error information
+ * pertains. */
+ unsigned char op, /* The instruction where the illegal
+ * type was found. */
+ Tcl_Obj *opndPtr) /* Points to the operand holding the value
+ * with the illegal type. */
+{
+ IllegalExprOperandType(interp, &op, opndPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclBitWiseBignumOp --
+ *
+ * Perform a bitwise operation on bignums.
+ *
+ * Results:
+ * Result of operation.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclBitWiseBignumOp (
+ unsigned char op,
+ mp_int *big1,
+ mp_int *big2,
+ mp_int *result)
+{
+ mp_int bigResult;
+ mp_int *First, *Second;
+ int numPos;
+
+ /*
+ * 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 (op) {
+ 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_exch(result, &bigResult);
+ mp_clear(&bigResult);
+}
/*
*----------------------------------------------------------------------
diff -ru ../tcl-20061206/generic/tclInt.h ./generic/tclInt.h
--- ../tcl-20061206/generic/tclInt.h 2006-12-02 08:03:13.000000000 +0100
+++ ./generic/tclInt.h 2006-12-05 13:21:35.000000000 +0100
@@ -2207,6 +2207,8 @@
MODULE_SCOPE int TclArraySet(Tcl_Interp *interp,
Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj);
MODULE_SCOPE double TclBignumToDouble(mp_int *bignum);
+MODULE_SCOPE void TclBitWiseBignumOp (unsigned char op, mp_int *big1,
+ mp_int *big2, mp_int *result);
MODULE_SCOPE double TclCeil(mp_int *a);
MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp,CONST char *value);
MODULE_SCOPE int TclChanCreateObjCmd(ClientData clientData,
@@ -2272,6 +2274,8 @@
MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern,
Tcl_Obj *unquotedPrefix, int globFlags,
Tcl_GlobTypeData *types);
+MODULE_SCOPE void TclIllegalExprOperandType(Tcl_Interp *interp,
+ unsigned char op, Tcl_Obj *opndPtr);
MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr,
Tcl_Obj *incrPtr);
MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
@@ -2408,6 +2412,8 @@
MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result);
MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
int count, int *tokensLeftPtr, int line);
+MODULE_SCOPE int TclStrCompare(Tcl_Obj *obj1Ptr, Tcl_Obj *obj2Ptr,
+ int nocase, int reqlength, int equal);
MODULE_SCOPE void TclTransferResult(Tcl_Interp *sourceInterp, int result,
Tcl_Interp *targetInterp);
MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData);
diff -ru ../tcl-20061206/generic/tclMathOp.c ./generic/tclMathOp.c
--- ../tcl-20061206/generic/tclMathOp.c 2006-12-02 08:03:13.000000000 +0100
+++ ./generic/tclMathOp.c 2006-12-06 16:36:53.000000000 +0100
@@ -50,9 +50,9 @@
*/
static Tcl_Obj * CombineIntFloat(Tcl_Interp *interp, Tcl_Obj *valuePtr,
- int opcode, Tcl_Obj *value2Ptr);
+ unsigned char opcode, Tcl_Obj *value2Ptr);
static Tcl_Obj * CombineIntOnly(Tcl_Interp *interp, Tcl_Obj *valuePtr,
- int opcode, Tcl_Obj *value2Ptr);
+ unsigned char opcode, Tcl_Obj *value2Ptr);
static int CompareNumbers(Tcl_Interp *interp, Tcl_Obj *numObj1,
Tcl_Obj *numObj2, int *resultPtr);
@@ -80,22 +80,21 @@
CombineIntFloat(
Tcl_Interp *interp, /* Place to write error messages. */
Tcl_Obj *valuePtr, /* First value to combine. */
- int opcode, /* Operation to use to combine the
+ unsigned char 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;
+ TclIllegalExprOperandType(interp, opcode, valuePtr);
+ return NULL;
}
#ifdef ACCEPT_NAN
@@ -110,8 +109,8 @@
|| (type2 == TCL_NUMBER_NAN)
#endif
) {
- errPtr = value2Ptr;
- goto illegalOperand;
+ TclIllegalExprOperandType(interp, opcode, value2Ptr);
+ return NULL;
}
#ifdef ACCEPT_NAN
@@ -331,7 +330,7 @@
{
/* Must check for overflow */
if (((w1 < 0) && (w2 > 0) && (wResult > 0))
- || ((w1 > 0) && (w2 < 0) && (wResult < 0))) {
+ || ((w1 >= 0) && (w2 < 0) && (wResult < 0))) {
goto overflow;
}
}
@@ -421,44 +420,6 @@
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);
@@ -496,137 +457,34 @@
CombineIntOnly(
Tcl_Interp *interp, /* Place to write error messages. */
Tcl_Obj *valuePtr, /* First value to combine. */
- int opcode, /* Operation to use to combine the
+ unsigned char 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;
+ TclIllegalExprOperandType(interp, opcode, valuePtr);
+ return NULL;
}
if ((TclGetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK)
|| (type2 == TCL_NUMBER_NAN) || (type2 == TCL_NUMBER_DOUBLE)) {
- errPtr = value2Ptr;
- goto illegalOperand;
+ TclIllegalExprOperandType(interp, opcode, value2Ptr);
+ return NULL;
}
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;
- }
+ TclBitWiseBignumOp(opcode, &big1, &big2, &bigResult);
mp_clear(&big1);
mp_clear(&big2);
@@ -690,41 +548,7 @@
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;
- }
+ return NULL;
}
/*
@@ -1034,6 +858,118 @@
/*
*----------------------------------------------------------------------
*
+ * TclStrCompare --
+ *
+ * Compare two strings.
+ *
+ * Results:
+ * -1 : less than
+ * 0 : equal
+ * 1 : greater than (or non-equal if equal is true)
+ *
+ * Side effects:
+ * Values may get their string representation filled in or change
+ * internal representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclStrCompare(
+ Tcl_Obj *obj1Ptr, /* First value to compare */
+ Tcl_Obj *obj2Ptr, /* Second value to compare */
+ int nocase, /* true for case insensitive compare */
+ int reqlength, /* How many characters to compare. -1 for all */
+ int equal) /* true if only equality is interesting */
+{
+ char *string1, *string2;
+ int length1, length2;
+ int match, length;
+ typedef int (*strCmpFn_t)(const char *, const char *, unsigned int);
+ strCmpFn_t strCmpFn;
+
+ if ((reqlength == 0) || (obj1Ptr == obj2Ptr)) {
+ /*
+ * Always match at 0 chars or if it is the same obj.
+ */
+
+ return 0;
+ } else if (!nocase && obj1Ptr->typePtr == &tclByteArrayType &&
+ obj2Ptr->typePtr == &tclByteArrayType) {
+ /*
+ * Use binary versions of comparisons since that won't cause undue
+ * type conversions and it is much faster. Only do this if we're
+ * case-sensitive (which is all that really makes sense with byte
+ * arrays anyway, and we have no memcasecmp() for some
+ * reason... :^)
+ */
+
+ string1 = (char*) Tcl_GetByteArrayFromObj(obj1Ptr, &length1);
+ string2 = (char*) Tcl_GetByteArrayFromObj(obj2Ptr, &length2);
+ strCmpFn = (strCmpFn_t) memcmp;
+ } else if ((obj1Ptr->typePtr == &tclStringType)
+ && (obj2Ptr->typePtr == &tclStringType)) {
+ /*
+ * Do a unicode-specific comparison if both of the args are of
+ * String type. In benchmark testing this proved the most
+ * efficient check between the unicode and string comparison
+ * operations.
+ */
+
+ string1 = (char*) Tcl_GetUnicodeFromObj(obj1Ptr, &length1);
+ string2 = (char*) Tcl_GetUnicodeFromObj(obj2Ptr, &length2);
+ strCmpFn = (strCmpFn_t)
+ (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp);
+ } else {
+ /*
+ * As a catch-all we will work with UTF-8. We cannot use memcmp()
+ * as that is unsafe with any string containing NULL (\xC0\x80 in
+ * Tcl's utf rep). We can use the more efficient TclpUtfNcmp2 if
+ * we are case-sensitive and no specific length was requested.
+ */
+
+ string1 = (char*) Tcl_GetStringFromObj(obj1Ptr, &length1);
+ string2 = (char*) Tcl_GetStringFromObj(obj2Ptr, &length2);
+ if ((reqlength < 0) && !nocase) {
+ strCmpFn = (strCmpFn_t) TclpUtfNcmp2;
+ } else {
+ length1 = Tcl_NumUtfChars(string1, length1);
+ length2 = Tcl_NumUtfChars(string2, length2);
+ strCmpFn = (strCmpFn_t)
+ (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp);
+ }
+ }
+
+ if (equal && (reqlength < 0) && (length1 != length2)) {
+ return 1;
+ }
+
+ length = (length1 < length2) ? length1 : length2;
+ if (reqlength > 0 && reqlength < length) {
+ length = reqlength;
+ } else if (reqlength < 0) {
+ /*
+ * The requested length is negative, so we ignore it by
+ * setting it to length + 1 so we correct the match var.
+ */
+
+ reqlength = length + 1;
+ }
+
+ match = strCmpFn(string1, string2, (unsigned) length);
+ if ((match == 0) && (reqlength > length)) {
+ match = length1 - length2;
+ }
+ if (equal) {
+ return (match != 0) ? 1 : 0;
+ } else {
+ return (match > 0) ? 1 : (match < 0) ? -1 : 0;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclInvertOpCmd --
*
* This procedure is invoked to process the "::tcl::mathop::~" Tcl
@@ -1063,6 +999,7 @@
return TCL_ERROR;
}
if (TclGetNumberFromObj(interp, objv[1], &val, &type) != TCL_OK) {
+ TclIllegalExprOperandType(interp, INST_BITNOT, objv[1]);
return TCL_ERROR;
}
switch (type) {
@@ -1080,7 +1017,7 @@
return TCL_OK;
}
#endif
- default: {
+ case TCL_NUMBER_BIG: {
mp_int big;
Tcl_TakeBignumFromObj(NULL, objv[1], &big);
@@ -1096,6 +1033,9 @@
return TCL_OK;
}
}
+
+ TclIllegalExprOperandType(interp, INST_BITNOT, objv[1]);
+ return TCL_ERROR;
}
/*
@@ -1129,6 +1069,7 @@
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[1], &b) != TCL_OK) {
+ TclIllegalExprOperandType(interp, INST_LNOT, objv[1]);
return TCL_ERROR;
}
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), !b);
@@ -1163,6 +1104,12 @@
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) {
+ TclIllegalExprOperandType(interp, INST_ADD, objv[1]);
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
} else if (objc == 3) {
@@ -1229,6 +1176,12 @@
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) {
+ TclIllegalExprOperandType(interp, INST_MULT, objv[1]);
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
} else if (objc == 3) {
@@ -1295,6 +1248,13 @@
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)
+ || (type1 == TCL_NUMBER_NAN) || (type1 == TCL_NUMBER_DOUBLE)) {
+ TclIllegalExprOperandType(interp, INST_BITAND, objv[1]);
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
} else if (objc == 3) {
@@ -1361,6 +1321,13 @@
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)
+ || (type1 == TCL_NUMBER_NAN) || (type1 == TCL_NUMBER_DOUBLE)) {
+ TclIllegalExprOperandType(interp, INST_BITOR, objv[1]);
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
} else if (objc == 3) {
@@ -1427,6 +1394,13 @@
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)
+ || (type1 == TCL_NUMBER_NAN) || (type1 == TCL_NUMBER_DOUBLE)) {
+ TclIllegalExprOperandType(interp, INST_BITXOR, objv[1]);
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
} else if (objc == 3) {
@@ -1493,6 +1467,12 @@
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)) {
+ TclIllegalExprOperandType(interp, INST_EXPON, objv[1]);
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
} else if (objc == 3) {
@@ -1716,8 +1696,7 @@
Tcl_Obj *const objv[])
{
ClientData ptr1, ptr2;
- int invalid, shift, type1, type2, idx;
- const char *description;
+ int invalid, shift, type1, type2;
long l1;
if (objc != 3) {
@@ -1727,13 +1706,13 @@
if ((TclGetNumberFromObj(NULL, objv[1], &ptr1, &type1) != TCL_OK)
|| (type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) {
- idx = 1;
- goto illegalOperand;
+ TclIllegalExprOperandType(interp, INST_LSHIFT, objv[1]);
+ return TCL_ERROR;
}
if ((TclGetNumberFromObj(NULL, objv[2], &ptr2, &type2) != TCL_OK)
|| (type2 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_NAN)) {
- idx = 2;
- goto illegalOperand;
+ TclIllegalExprOperandType(interp, INST_LSHIFT, objv[2]);
+ return TCL_ERROR;
}
/* reject negative shift argument */
@@ -1767,7 +1746,9 @@
}
/* Large left shifts create integer overflow */
- if (Tcl_GetIntFromObj(NULL, objv[2], &shift) != TCL_OK) {
+ if ((type2 != TCL_NUMBER_LONG) ||
+ (*((const long *)ptr2) > (long) INT_MAX) ||
+ Tcl_GetIntFromObj(NULL, objv[2], &shift) != TCL_OK) {
/*
* 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
@@ -1817,27 +1798,6 @@
}
}
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;
}
/*
@@ -1865,8 +1825,7 @@
Tcl_Obj *const objv[])
{
ClientData ptr1, ptr2;
- int invalid, shift, type1, type2, idx;
- const char *description;
+ int invalid, shift, type1, type2;
long l1;
if (objc != 3) {
@@ -1876,13 +1835,13 @@
if ((TclGetNumberFromObj(NULL, objv[1], &ptr1, &type1) != TCL_OK)
|| (type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) {
- idx = 1;
- goto illegalOperand;
+ TclIllegalExprOperandType(interp, INST_RSHIFT, objv[1]);
+ return TCL_ERROR;
}
if ((TclGetNumberFromObj(NULL, objv[2], &ptr2, &type2) != TCL_OK)
|| (type2 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_NAN)) {
- idx = 2;
- goto illegalOperand;
+ TclIllegalExprOperandType(interp, INST_RSHIFT, objv[2]);
+ return TCL_ERROR;
}
/* reject negative shift argument */
@@ -1997,27 +1956,6 @@
}
}
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;
}
/*
@@ -2044,11 +1982,9 @@
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");
@@ -2057,13 +1993,13 @@
if ((TclGetNumberFromObj(NULL, objv[1], &ptr1, &type1) != TCL_OK)
|| (type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) {
- argObj = objv[1];
- goto badArg;
+ TclIllegalExprOperandType(interp, INST_MOD, objv[1]);
+ return TCL_ERROR;
}
if ((TclGetNumberFromObj(NULL, objv[2], &ptr2, &type2) != TCL_OK)
|| (type2 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_NAN)) {
- argObj = objv[2];
- goto badArg;
+ TclIllegalExprOperandType(interp, INST_MOD, objv[2]);
+ return TCL_ERROR;
}
if (type2 == TCL_NUMBER_LONG) {
@@ -2203,27 +2139,6 @@
}
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;
}
/*
@@ -2250,8 +2165,7 @@
int objc,
Tcl_Obj *const objv[])
{
- int result = 1, cmp, len1, len2;
- const char *str1, *str2;
+ int result = 1, cmp;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "value value");
@@ -2263,9 +2177,8 @@
/*
* Got a string
*/
- str1 = Tcl_GetStringFromObj(objv[1], &len1);
- str2 = Tcl_GetStringFromObj(objv[2], &len2);
- if (len1 == len2 && !strcmp(str1, str2)) {
+
+ if (TclStrCompare(objv[1], objv[2], 0, -1, 1) == 0) {
result = 0;
}
case TCL_BREAK: /* Deliberate fallthrough */
@@ -2274,7 +2187,8 @@
/*
* Got proper numbers
*/
- if (cmp != MP_EQ) {
+
+ if (cmp == MP_EQ) {
result = 0;
}
}
@@ -2306,21 +2220,15 @@
int objc,
Tcl_Obj *const objv[])
{
- const char *s1, *s2;
- int s1len, s2len;
+ int compare;
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);
- }
+ compare = TclStrCompare(objv[1], objv[2], 0, -1, 1);
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(compare != 0));
return TCL_OK;
}
@@ -2447,8 +2355,7 @@
int result = 1;
if (objc > 2) {
- int i, cmp, len1, len2;
- const char *str1, *str2;
+ int i, cmp;
for (i=1 ; i<objc-1 ; i++) {
switch (CompareNumbers(NULL, objv[i], objv[i+1], &cmp)) {
@@ -2456,10 +2363,8 @@
/*
* 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) {
+
+ if (TclStrCompare(objv[i], objv[i+1], 0, -1, 0) >= 0) {
result = 0;
i = objc;
}
@@ -2468,6 +2373,7 @@
/*
* Got proper numbers
*/
+
if (cmp != MP_LT) {
result = 0;
i = objc;
@@ -2478,6 +2384,7 @@
* Got a NaN (which is different from everything, including
* itself)
*/
+
result = 0;
i = objc;
continue;
@@ -2515,8 +2422,7 @@
int result = 1;
if (objc > 2) {
- int i, cmp, len1, len2;
- const char *str1, *str2;
+ int i, cmp;
for (i=1 ; i<objc-1 ; i++) {
switch (CompareNumbers(NULL, objv[i], objv[i+1], &cmp)) {
@@ -2524,10 +2430,8 @@
/*
* 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) {
+
+ if (TclStrCompare(objv[i], objv[i+1], 0, -1, 0) > 0) {
result = 0;
i = objc;
}
@@ -2536,6 +2440,7 @@
/*
* Got proper numbers
*/
+
if (cmp == MP_GT) {
result = 0;
i = objc;
@@ -2546,6 +2451,7 @@
* Got a NaN (which is different from everything, including
* itself)
*/
+
result = 0;
i = objc;
continue;
@@ -2583,8 +2489,7 @@
int result = 1;
if (objc > 2) {
- int i, cmp, len1, len2;
- const char *str1, *str2;
+ int i, cmp;
for (i=1 ; i<objc-1 ; i++) {
switch (CompareNumbers(NULL, objv[i], objv[i+1], &cmp)) {
@@ -2592,10 +2497,8 @@
/*
* 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) {
+
+ if (TclStrCompare(objv[i], objv[i+1], 0, -1, 0) <= 0) {
result = 0;
i = objc;
}
@@ -2604,6 +2507,7 @@
/*
* Got proper numbers
*/
+
if (cmp != MP_GT) {
result = 0;
i = objc;
@@ -2614,6 +2518,7 @@
* Got a NaN (which is different from everything, including
* itself)
*/
+
result = 0;
i = objc;
continue;
@@ -2651,8 +2556,7 @@
int result = 1;
if (objc > 2) {
- int i, cmp, len1, len2;
- const char *str1, *str2;
+ int i, cmp;
for (i=1 ; i<objc-1 ; i++) {
switch (CompareNumbers(NULL, objv[i], objv[i+1], &cmp)) {
@@ -2660,10 +2564,8 @@
/*
* 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) {
+
+ if (TclStrCompare(objv[i], objv[i+1], 0, -1, 0) < 0) {
result = 0;
i = objc;
}
@@ -2672,6 +2574,7 @@
/*
* Got proper numbers
*/
+
if (cmp == MP_LT) {
result = 0;
i = objc;
@@ -2682,6 +2585,7 @@
* Got a NaN (which is different from everything, including
* itself)
*/
+
result = 0;
i = objc;
continue;
@@ -2719,8 +2623,7 @@
int result = 1;
if (objc > 2) {
- int i, cmp, len1, len2;
- const char *str1, *str2;
+ int i, cmp;
for (i=1 ; i<objc-1 ; i++) {
switch (CompareNumbers(NULL, objv[i], objv[i+1], &cmp)) {
@@ -2728,9 +2631,8 @@
/*
* Got a string
*/
- str1 = Tcl_GetStringFromObj(objv[i], &len1);
- str2 = Tcl_GetStringFromObj(objv[i+1], &len2);
- if (len1 != len2 || strcmp(str1, str2)) {
+
+ if (TclStrCompare(objv[i], objv[i+1], 0, -1, 1) != 0) {
result = 0;
i = objc;
}
@@ -2786,13 +2688,10 @@
int result = 1;
if (objc > 2) {
- int i, len1, len2;
- const char *str1, *str2;
+ int i;
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)) {
+ if (TclStrCompare(objv[i], objv[i+1], 0, -1, 1) != 0) {
result = 0;
break;
}
diff -ru ../tcl-20061206/tests/mathop.test ./tests/mathop.test
--- ../tcl-20061206/tests/mathop.test 2006-12-07 08:02:35.000000000 +0100
+++ ./tests/mathop.test 2006-12-07 13:18:27.000000000 +0100
@@ -5,6 +5,7 @@
# for errors. No output means no errors were found.
#
# Copyright (c) 2006 Donal K. Fellows
+# Copyright (c) 2006 Peter Spjuth
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -16,6 +17,87 @@
namespace import -force ::tcltest::*
}
+# A namespace to test that operators are exported and that they
+# work when imported
+namespace eval ::testmathop2 {
+ namespace import ::tcl::mathop::*
+}
+
+# Helper to test math ops.
+# Test different invokation variants and see that they do the same thing.
+# Byte compiled / non byte compiled version
+# Shared / unshared arguments
+# Original / imported
+proc TestOp {op args} {
+ set results {}
+
+ # Non byte compiled version, shared args
+ if {[catch {::tcl::mathop::$op {expand}$args} res]} {
+ append res " $::errorCode"
+ }
+ lappend results $res
+
+ # Non byte compiled version, unshared args
+ set cmd ::tcl::mathop::\$op
+ foreach arg $args {
+ append cmd " \[format %s [list $arg]\]"
+ }
+ if {[catch $cmd res]} {
+ append res " $::errorCode"
+ }
+ lappend results $res
+
+ # Non byte compiled imported
+ if {[catch {::testmathop2::$op {expand}$args} res]} {
+ append res " $::errorCode"
+ }
+ lappend results [string map {testmathop2 tcl::mathop} $res]
+
+ # BC version
+ set argList1 {}
+ set argList2 {}
+ set argList3 {}
+ for {set t 0} {$t < [llength $args]} {incr t} {
+ lappend argList1 a$t
+ lappend argList2 \$a$t
+ lappend argList3 "\[format %s \$a$t\]"
+ }
+ # Shared args
+ proc _TestOp $argList1 "::tcl::mathop::$op [join $argList2]"
+ # Unshared args
+ proc _TestOp2 $argList1 "::tcl::mathop::$op [join $argList3]"
+ # Imported
+ proc _TestOp3 $argList1 "::testmathop2::$op [join $argList2]"
+
+ set ::tcl_traceCompile 0 ;# Set to 2 to help with debug
+ if {[catch {_TestOp {expand}$args} res]} {
+ append res " $::errorCode"
+ }
+ set ::tcl_traceCompile 0
+ lappend results $res
+
+ if {[catch {_TestOp2 {expand}$args} res]} {
+ append res " $::errorCode"
+ }
+ lappend results $res
+
+ if {[catch {_TestOp3 {expand}$args} res]} {
+ append res " $::errorCode"
+ }
+ lappend results [string map {testmathop2 tcl::mathop} $res]
+
+ # Check that they do the same
+ set len [llength $results]
+ for {set i 0} {$i < ($len - 1)} {incr i} {
+ set res1 [lindex $results $i]
+ set res2 [lindex $results $i+1]
+ if {$res1 ne $res2} {
+ return "$i:($res1 != $res2)"
+ }
+ }
+ return [lindex $results 0]
+}
+
# start of tests
namespace eval ::testmathop {
@@ -53,7 +135,7 @@
+ 0 [error expectedError]
} -result expectedError
test mathop-1.18 {compiled +: argument processing order} -body {
- # Bytecode compilation known buggy for 3+ arguments
+ # Bytecode compilation known hard for 3+ arguments
list [catch {
+ [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
} msg] $msg $x
@@ -128,7 +210,7 @@
* 0 [error expectedError]
} -result expectedError
test mathop-2.18 {compiled *: argument processing order} -body {
- # Bytecode compilation known buggy for 3+ arguments
+ # Bytecode compilation known hard for 3+ arguments
list [catch {
* [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
} msg] $msg $x
@@ -172,10 +254,658 @@
} -result {1 expected 2}
# TODO: ! ~ & | ^ % ** << >> - / == != < <= > >= eq ne in ni
+
+ test mathop-3.18 {compiled /: argument processing order} -body {
+ # Bytecode compilation known hard for 3+ arguments
+ list [catch {
+ / [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
+ } msg] $msg $x
+ } -result {1 expected 2}
+
+ test mathop-4.18 {compiled -: argument processing order} -body {
+ # Bytecode compilation known hard for 3+ arguments
+ list [catch {
+ - [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
+ } msg] $msg $x
+ } -result {1 expected 2}
+}
+
+
+test mathop-20.1 { zero args, return unit } {
+ set res {}
+ foreach op {+ * & ^ | ** < <= > >= == eq} {
+ lappend res [TestOp $op]
+ }
+ set res
+} {0 1 -1 0 0 1 1 1 1 1 1 1}
+
+test mathop-20.2 { zero args, not allowed } {
+ set exp {}
+ foreach op {~ ! << >> % != ne in ni - /} {
+ set res [TestOp $op]
+ if {[string match "wrong # args* NONE" $res]} {
+ lappend exp 0
+ } else {
+ lappend exp $res
+ }
+ }
+ set exp
+} {0 0 0 0 0 0 0 0 0 0 0}
+
+test mathop-20.3 { one arg } {
+ set res {}
+ foreach val {7 8.3} {
+ foreach op {+ ** - * / < <= > >= == eq !} {
+ lappend res [TestOp $op $val]
+ }
+ }
+ set res
+} [list 7 7 -7 7 [expr {1.0/7.0}] 1 1 1 1 1 1 0 \
+ 8.3 8.3 -8.3 8.3 [expr {1.0/8.3}] 1 1 1 1 1 1 0]
+
+test mathop-20.4 { one arg, integer only ops } {
+ set res {}
+ foreach val {23} {
+ foreach op {& | ^ ~} {
+ lappend res [TestOp $op $val]
+ }
+ }
+ set res
+} [list 23 23 23 -24]
+
+test mathop-20.5 { one arg, not allowed } {
+ set exp {}
+ foreach op {% != ne in ni << >>} {
+ set res [TestOp $op 1]
+ if {[string match "wrong # args* NONE" $res]} {
+ lappend exp 0
+ } else {
+ lappend exp $res
+ }
+ }
+ set exp
+} {0 0 0 0 0 0 0}
+
+test mathop-20.6 { one arg, error } {
+ set res {}
+ set exp {}
+ foreach vals {x {1 x} {1 1 x} {1 x 1}} {
+ # skipping - for now, knownbug...
+ foreach op {+ * / & | ^ **} {
+ lappend res [TestOp $op {expand}$vals]
+ lappend exp "can't use non-numeric string as operand of \"$op\" NONE"
+ }
+ }
+ expr {$res eq $exp ? 0 : $res}
+} 0
+
+test mathop-20.7 { multi arg } {
+ set res {}
+ foreach vals {{1 2} {3 4 5} {4 3 2 1}} {
+ foreach op {+ - * /} {
+ lappend res [TestOp $op {expand}$vals]
+ }
+ }
+ set res
+} [list 3 -1 2 0 12 -6 60 0 10 -2 24 0]
+
+test mathop-20.8 { multi arg, double } {
+ set res {}
+ foreach vals {{1.0 2} {3.0 4 5} {4 3.0 2 1}} {
+ foreach op {+ - * /} {
+ lappend res [TestOp $op {expand}$vals]
+ }
+ }
+ set res
+} [list 3.0 -1.0 2.0 0.5 12.0 -6.0 60.0 0.15 10.0 -2.0 24.0 [expr {2.0/3}]]
+
+test mathop-21.1 { unary ops, bitnot } {
+ set res {}
+ lappend res [TestOp ~ 7]
+ lappend res [TestOp ~ -5]
+ lappend res [TestOp ~ 354657483923456]
+ lappend res [TestOp ~ 123456789123456789123456789]
+ set res
+} [list -8 4 -354657483923457 -123456789123456789123456790]
+
+test mathop-21.2 { unary ops, logical not } {
+ set res {}
+ lappend res [TestOp ! 0]
+ lappend res [TestOp ! 1]
+ lappend res [TestOp ! true]
+ lappend res [TestOp ! false]
+ lappend res [TestOp ! 37]
+ lappend res [TestOp ! 8.5]
+ set res
+} [list 1 0 0 1 0 0]
+
+test mathop-21.3 { unary ops, negation } {
+ set res {}
+ lappend res [TestOp - 7.2]
+ lappend res [TestOp - -5]
+ lappend res [TestOp - -2147483648] ;# -2**31
+ lappend res [TestOp - -9223372036854775808] ;# -2**63
+ lappend res [TestOp - 354657483923456] ;# wide
+ lappend res [TestOp - 123456789123456789123456789] ;# big
+ set res
+} [list -7.2 5 2147483648 9223372036854775808 -354657483923456 \
+ -123456789123456789123456789]
+
+test mathop-21.4 { unary ops, inversion } {
+ set res {}
+ lappend res [TestOp / 1]
+ lappend res [TestOp / 5]
+ lappend res [TestOp / 5.6]
+ lappend res [TestOp / -8]
+ lappend res [TestOp / 354657483923456] ;# wide
+ lappend res [TestOp / 123456789123456789123456789] ;# big
+ set res
+} [list 1.0 0.2 0.17857142857142858 -0.125 \
+ 2.8196218755553604e-15 8.10000006561e-27]
+
+test mathop-21.5 { unary ops, bad values } {
+ set res {}
+ set exp {}
+ lappend res [TestOp / x]
+ lappend exp "can't use non-numeric string as operand of \"/\" NONE"
+ lappend res [TestOp - x]
+ lappend exp "can't use non-numeric string as operand of \"-\" NONE"
+ lappend res [TestOp ~ x]
+ lappend exp "can't use non-numeric string as operand of \"~\" NONE"
+ lappend res [TestOp ! x]
+ lappend exp "can't use non-numeric string as operand of \"!\" NONE"
+ lappend res [TestOp ~ 5.0]
+ lappend exp "can't use floating-point value as operand of \"~\" NONE"
+ expr {$res eq $exp ? 0 : $res}
+} 0
+
+test mathop-21.6 { unary ops, too many } {
+ set exp {}
+ foreach op {~ !} {
+ set res [TestOp $op 7 8]
+ if {[string match "wrong # args* NONE" $res]} {
+ lappend exp 0
+ } else {
+ lappend exp $res
+ }
+ }
+ set exp
+} {0 0}
+
+test mathop-22.1 { bitwise ops } {
+ set res {}
+ foreach vals {5 {1 6} {1 2 3} {1 2 3 4}} {
+ foreach op {& | ^} {
+ lappend res [TestOp $op {expand}$vals]
+ }
+ }
+ set res
+} [list 5 5 5 0 7 7 0 3 0 0 7 4]
+
+test mathop-22.2 { bitwise ops on bignums } {
+ set dig 50
+ set a 0x[string repeat 5 $dig]
+ set b 0x[string repeat 7 $dig]
+ set c 0x[string repeat 9 $dig]
+ set bn [expr {~$b}]
+ set cn [expr {~$c}]
+
+ set res {}
+ foreach vals [list [list $a $b] [list $a $c] [list $b $c] \
+ [list $a $bn] [list $bn $c] [list $bn $cn]] {
+ foreach op {& | ^} {
+ lappend res [TestOp $op {expand}$vals]
+ }
+ }
+ set exp {}
+ foreach d {5 7 2 1 D C 1 F E 0 -D -D 8 -9 -1 -0 -E E} {
+ if {[string match "-*" $d]} {
+ set d [format %X [expr 15-0x[string range $d 1 end]]]
+ set val [expr -0x[string repeat $d $dig]-1]
+ } else {
+ set val [expr 0x[string repeat $d $dig]]
+ }
+ lappend exp $val
+ }
+ expr {$exp eq $res ? 1 : "($res != $exp"}
+} 1
+
+test mathop-22.3 { bitwise ops } {
+ set big1 12135435435354435435342423948763867876
+ set big2 2746237174783836746262564892918327847
+ set wide1 12345678912345
+ set wide2 87321847232215
+ set small1 87345
+ set small2 16753
+
+ set res {}
+ foreach op {& | ^} {
+ lappend res [TestOp $op $big1 $big2]
+ lappend res [TestOp $op $big1 $wide2]
+ lappend res [TestOp $op $big1 $small2]
+ lappend res [TestOp $op $wide1 $big2]
+ lappend res [TestOp $op $wide1 $wide2]
+ lappend res [TestOp $op $wide1 $small2]
+ lappend res [TestOp $op $small1 $big2]
+ lappend res [TestOp $op $small1 $wide2]
+ lappend res [TestOp $op $small1 $small2]
+ }
+ set res
+} [list \
+ 712439449294653815890598856501796 \
+ 78521450111684 \
+ 96 \
+ 2371422390785 \
+ 12275881497169 \
+ 16721 \
+ 33 \
+ 87057 \
+ 16689 \
+ 14880960170688977527789098242825693927 \
+ 12135435435354435435342432749160988407 \
+ 12135435435354435435342423948763884533 \
+ 2746237174783836746262574867174849407 \
+ 87391644647391 \
+ 12345678912377 \
+ 2746237174783836746262564892918415159 \
+ 87321847232503 \
+ 87409 \
+ 14880247731239682873973207643969192131 \
+ 12135435435354435435342354227710876723 \
+ 12135435435354435435342423948763884437 \
+ 2746237174783836746262572495752458622 \
+ 75115763150222 \
+ 12345678895656 \
+ 2746237174783836746262564892918415126 \
+ 87321847145446 \
+ 70720 \
+ ]
+
+test mathop-22.4 { unary ops, bad values } {
+ set res {}
+ set exp {}
+ foreach op {& | ^} {
+ lappend res [TestOp $op x 5]
+ lappend exp "can't use non-numeric string as operand of \"$op\" NONE"
+ lappend res [TestOp $op 5 x]
+ lappend exp "can't use non-numeric string as operand of \"$op\" NONE"
+ }
+ expr {$res eq $exp ? 0 : $res}
+} 0
+
+test mathop-23.1 { comparison ops, numerical } {
+ set res {}
+ set todo {5 {1 6} {1 2 2 3} {4 3 2 1} {5.0 5.0} {6 3 3 1} {5.0 5}}
+ lappend todo [list 2342476234762482734623842342 234827463876473 3434]
+ lappend todo [list 2653 453735910264536 453735910264537 2384762472634982746239847637]
+ lappend todo [list 2653 2384762472634982746239847637]
+ lappend todo [list 2653 -2384762472634982746239847637]
+ lappend todo [list 3789253678212653 -2384762472634982746239847637]
+ lappend todo [list 5.0 6 7.0 8 1e13 1945628567352654 1.1e20 \
+ 6734253647589123456784564378 2.3e50]
+ set a 7
+ lappend todo [list $a $a] ;# Same object
+ foreach vals $todo {
+ foreach op {< <= > >= == eq} {
+ lappend res [TestOp $op {expand}$vals]
+ }
+ }
+ set res
+} [list 1 1 1 1 1 1 \
+ 1 1 0 0 0 0 \
+ 0 1 0 0 0 0 \
+ 0 0 1 1 0 0 \
+ 0 1 0 1 1 1 \
+ 0 0 0 1 0 0 \
+ 0 1 0 1 1 0 \
+ 0 0 1 1 0 0 \
+ 1 1 0 0 0 0 \
+ 1 1 0 0 0 0 \
+ 0 0 1 1 0 0 \
+ 0 0 1 1 0 0 \
+ 1 1 0 0 0 0 \
+ 0 1 0 1 1 1 \
+ ]
+
+test mathop-23.2 { comparison ops, string } {
+ set res {}
+ set todo {a {a b} {5 b b c} {d c b a} {xy xy} {gy ef ef ab}}
+ set a x
+ lappend todo [list $a $a]
+ foreach vals $todo {
+ foreach op {< <= > >= == eq} {
+ lappend res [TestOp $op {expand}$vals]
+ }
+ }
+ set res
+} [list 1 1 1 1 1 1 \
+ 1 1 0 0 0 0 \
+ 0 1 0 0 0 0 \
+ 0 0 1 1 0 0 \
+ 0 1 0 1 1 1 \
+ 0 0 0 1 0 0 \
+ 0 1 0 1 1 1 \
+ ]
+
+test mathop-23.3 { comparison ops, nonequal} {
+ set res {}
+ foreach vals {{a b} {17.0 0x11} {foo foo} {10 10}} {
+ foreach op {!= ne} {
+ lappend res [TestOp $op {expand}$vals]
+ }
+ }
+ set res
+} [list 1 1 0 1 0 0 0 0 ]
+
+test mathop-24.1 { binary ops } {
+ set res {}
+ foreach vals {{3 5} {17 7} {199 5} {293234675763434238476239486 17} \
+ {5 1} {0 7}} {
+ foreach op {% << >> in ni} {
+ lappend res [TestOp $op {expand}$vals]
+ }
+ }
+ set res
+} [list 3 96 0 0 1 3 2176 0 0 1 4 6368 6 0 1 \
+ 14 38434855421664852505557661908992 2237203031642412097749 0 1 \
+ 0 10 2 0 1 0 0 0 0 1]
+
+test mathop-24.2 { binary ops, modulo } {
+ # Test different combinations to get all code paths
+ set res {}
+
+ set bigbig 14372423674564535234543545248972634923869
+ set big 12135435435354435435342423948763867876
+ set wide 12345678912345
+ set negwide -12345678912345
+ set small 5
+ set neg -5
+
+ lappend res [TestOp % $bigbig $big]
+ lappend res [TestOp % $wide $big]
+ lappend res [TestOp % $negwide $big]
+ lappend res [TestOp % $small $big]
+ lappend res [TestOp % $neg $big]
+ lappend res [TestOp % $small $wide]
+ lappend res [TestOp % $neg $wide]
+ lappend res [TestOp % $wide $small]
+ set res
+} [list 4068119104883679098115293636215358685 \
+ 12345678912345 \
+ 12135435435354435435342411603084955531 \
+ 5 \
+ 12135435435354435435342423948763867871 \
+ 5 \
+ 12345678912340 \
+ 0 \
+ ]
+
+test mathop-24.3 { binary ops, bad values } {
+ set res {}
+ set exp {}
+ foreach op {% << >>} {
+ lappend res [TestOp $op x 1]
+ lappend exp "can't use non-numeric string as operand of \"$op\" NONE"
+ lappend res [TestOp $op 1 x]
+ lappend exp "can't use non-numeric string as operand of \"$op\" NONE"
+ }
+ foreach op {% << >>} {
+ lappend res [TestOp $op 5.0 1]
+ lappend exp "can't use floating-point value as operand of \"$op\" NONE"
+ lappend res [TestOp $op 1 5.0]
+ lappend exp "can't use floating-point value as operand of \"$op\" NONE"
+ }
+ foreach op {in ni} {
+ lappend res [TestOp $op 5 "a b \{ c"]
+ lappend exp "unmatched open brace in list NONE"
+ }
+ lappend res [TestOp % 5 0]
+ lappend exp "divide by zero ARITH DIVZERO {divide by zero}"
+ lappend res [TestOp % 9838923468297346238478737647637375 0]
+ lappend exp "divide by zero ARITH DIVZERO {divide by zero}"
+ lappend res [TestOp / 5 0]
+ lappend exp "divide by zero ARITH DIVZERO {divide by zero}"
+ lappend res [TestOp / 9838923468297346238478737647637375 0]
+ lappend exp "divide by zero ARITH DIVZERO {divide by zero}"
+ expr {$res eq $exp ? 0 : $res}
+} 0
+
+test mathop-24.4 { binary ops, negative shift } {
+ set res {}
+
+ set big -12135435435354435435342423948763867876
+ set wide -12345678912345
+ set small -1
+
+ lappend res [TestOp << 10 $big]
+ lappend res [TestOp << 10 $wide]
+ lappend res [TestOp << 10 $small]
+ lappend res [TestOp >> 10 $big]
+ lappend res [TestOp >> 10 $wide]
+ lappend res [TestOp >> 10 $small]
+
+ set exp [lrepeat 6 "negative shift argument NONE"]
+ expr {$res eq $exp ? 0 : $res}
+} 0
+
+test mathop-24.5 { binary ops, large shift } {
+ set res {}
+ set exp {}
+
+ set big 12135435435354435435342423948763867876
+ set wide 12345678912345
+ set small 1
+
+ lappend res [TestOp << 1 2147483648]
+ lappend exp "integer value too large to represent NONE"
+ lappend res [TestOp << 1 4294967296]
+ lappend exp "integer value too large to represent NONE"
+ lappend res [TestOp << $small $wide]
+ lappend exp "integer value too large to represent NONE"
+ lappend res [TestOp << $small $big]
+ lappend exp "integer value too large to represent NONE"
+ lappend res [TestOp >> $big $wide]
+ lappend exp 0
+ lappend res [TestOp >> $big $big]
+ lappend exp 0
+ lappend res [TestOp >> $small 70]
+ lappend exp 0
+ lappend res [TestOp >> $wide 70]
+ lappend exp 0
+ lappend res [TestOp >> -$big $wide]
+ lappend exp -1
+ lappend res [TestOp >> -$wide $wide]
+ lappend exp -1
+ lappend res [TestOp >> -$small $wide]
+ lappend exp -1
+ lappend res [TestOp >> -$small 70]
+ lappend exp -1
+ lappend res [TestOp >> -$wide 70]
+ lappend exp -1
+
+ expr {$res eq $exp ? 0 : $res}
+} 0
+
+test mathop-24.6 { binary ops, shift } {
+ # Test different combinations to get all code paths
+ set res {}
+
+ set bigbig 14372423674564535234543545248972634923869
+ set big 12135435435354435435342423948763867876
+ set wide 12345678912345
+ set negwide -12345678912345
+ set small 5
+ set neg -5
+
+ lappend res [TestOp << $wide $small]
+ lappend res [TestOp >> $wide $small]
+ set res
+} [list 395061725195040 \
+ 385802466010 \
+ ]
+
+test mathop-24.7 { binary ops, list search } {
+ set res {}
+
+ foreach op {in ni} {
+ lappend res [TestOp $op 5 {7 5 8}]
+ lappend res [TestOp $op hej {foo bar hej}]
+ lappend res [TestOp $op 5 {7 0x5 8}]
+ }
+ set res
+} [list 1 1 0 0 0 1]
+
+test mathop-24.8 { binary ops, too many } {
+ set exp {}
+ foreach op {<< >> % != ne in ni ~ !} {
+ set res [TestOp $op 7 8 9]
+ if {[string match "wrong # args* NONE" $res]} {
+ lappend exp 0
+ } else {
+ lappend exp $res
+ }
+ }
+ set exp
+} {0 0 0 0 0 0 0 0 0}
+
+
+test mathop-25.1 { exp operator } {TestOp ** } 1
+test mathop-25.2 { exp operator } {TestOp ** 0 } 0
+test mathop-25.3 { exp operator } {TestOp ** 0 5} 0
+test mathop-25.4 { exp operator } {TestOp ** 7.5 } 7.5
+test mathop-25.5 { exp operator } {TestOp ** 1 5} 1
+test mathop-25.6 { exp operator } {TestOp ** 5 1} 5
+test mathop-25.7 { exp operator } {TestOp ** 4 3 2 1} 262144
+test mathop-25.8 { exp operator } {TestOp ** 5.5 4} 915.0625
+test mathop-25.9 { exp operator } {TestOp ** 6 3.5} 529.0897844411664
+test mathop-25.10 { exp operator } {TestOp ** 3.5 0} 1.0
+test mathop-25.11 { exp operator } {TestOp ** 378 0} 1
+test mathop-25.12 { exp operator } {TestOp ** 7.8 1} 7.8
+test mathop-25.13 { exp operator } {TestOp ** 748 1} 748
+test mathop-25.14 { exp operator } {TestOp ** 6.3 -1} 0.15873015873015872
+test mathop-25.15 { exp operator } {TestOp ** 683 -1} 0
+test mathop-25.16 { exp operator } {TestOp ** 1 -1} 1
+test mathop-25.17 { exp operator } {TestOp ** -1 -1} -1
+test mathop-25.18 { exp operator } {TestOp ** -1 -2} 1
+test mathop-25.19 { exp operator } {TestOp ** -1 3} -1
+test mathop-25.20 { exp operator } {TestOp ** -1 4} 1
+test mathop-25.21 { exp operator } {TestOp ** 2 63} 9223372036854775808
+test mathop-25.22 { exp operator } {TestOp ** 83756485763458746358734658473567847567473 2} 7015148907444467657897585474493757781161998914521537835809623408157343003287605729
+
+test mathop-25.23 { exp operator errors } {
+ set res {}
+ set exp {}
+
+ set huge [string repeat 145782 1000]
+ set big 12135435435354435435342423948763867876
+ set wide 12345678912345
+ set small 2
+
+ lappend res [TestOp ** 0 -5]
+ lappend exp "exponentiation of zero by negative power ARITH DOMAIN {exponentiation of zero by negative power}"
+ lappend res [TestOp ** 0.0 -5.0]
+ lappend exp "exponentiation of zero by negative power ARITH DOMAIN {exponentiation of zero by negative power}"
+ lappend res [TestOp ** $small $wide]
+ lappend exp "exponent too large NONE"
+ lappend res [TestOp ** 2 $big]
+ lappend exp "exponent too large NONE"
+ lappend res [TestOp ** $huge 2.1]
+ lappend exp "Inf"
+ lappend res [TestOp ** 2 foo]
+ lappend exp "can't use non-numeric string as operand of \"**\" NONE"
+ lappend res [TestOp ** foo 2]
+ lappend exp "can't use non-numeric string as operand of \"**\" NONE"
+
+ expr {$res eq $exp ? 0 : $res}
+} 0
+
+
+test mathop-26.1 { misc ops, size combinations } {
+ set big1 12135435435354435435342423948763867876
+ set big2 2746237174783836746262564892918327847
+ set wide1 87321847232215
+ set wide2 12345678912345
+ set small1 87345
+ set small2 16753
+
+ set res {}
+ foreach op {+ * - /} {
+ lappend res [TestOp $op $big1 $big2]
+ lappend res [TestOp $op $big1 $wide2]
+ lappend res [TestOp $op $big1 $small2]
+ lappend res [TestOp $op $wide1 $big2]
+ lappend res [TestOp $op $wide1 $wide2]
+ lappend res [TestOp $op $wide1 $small2]
+ lappend res [TestOp $op $small1 $big2]
+ lappend res [TestOp $op $small1 $wide2]
+ lappend res [TestOp $op $small1 $small2]
+ }
+ set res
+} [list \
+ 14881672610138272181604988841682195723 \
+ 12135435435354435435342436294442780221 \
+ 12135435435354435435342423948763884629 \
+ 2746237174783836746262652214765560062 \
+ 99667526144560 \
+ 87321847248968 \
+ 2746237174783836746262564892918415192 \
+ 12345678999690 \
+ 104098 \
+ 33326783924759424684447891401270222910405366244661685890993770489959542972 \
+ 149820189346379518024969783068410988366610965329220 \
+ 203304949848492856848291628413641078526628 \
+ 239806503039903915972546163440347114360602909991105 \
+ 1078047487961768329845194175 \
+ 1462902906681297895 \
+ 239870086031494220602303730571951345796215 \
+ 1078333324598774025 \
+ 1463290785 \
+ 9389198260570598689079859055845540029 \
+ 12135435435354435435342411603084955531 \
+ 12135435435354435435342423948763851123 \
+ -2746237174783836746262477571071095632 \
+ 74976168319870 \
+ 87321847215462 \
+ -2746237174783836746262564892918240502 \
+ -12345678825000 \
+ 70592 \
+ 4 \
+ 982970278225822587257201 \
+ 724373869477373332259441529801460 \
+ 0 \
+ 7 \
+ 5212311062 \
+ 0 \
+ 0 \
+ 5 \
+ ]
+
+test mathop-26.2 { misc ops, corner cases } {
+ set res {}
+ lappend res [TestOp - 0 -2147483648] ;# -2**31
+ lappend res [TestOp - 0 -9223372036854775808] ;# -2**63
+ lappend res [TestOp / -9223372036854775808 -1]
+ lappend res [TestOp * 2147483648 2]
+ lappend res [TestOp * 9223372036854775808 2]
+ set res
+} [list 2147483648 9223372036854775808 9223372036854775808 4294967296 18446744073709551616]
+
+if 0 {
+ # Compare ops to expr bytecodes
+ namespace import ::tcl::mathop::*
+ proc _X {a b c} {
+ set x [+ $a [- $b $c]]
+ set y [expr {$a + ($b - $c)}]
+ set z [< $a $b $c]
+ }
+ set ::tcl_traceCompile 2
+ _X 3 4 5
+ set ::tcl_traceCompile 0
}
# cleanup
namespace delete ::testmathop
+namespace delete ::testmathop2
::tcltest::cleanupTests
return
