summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog8
-rw-r--r--generic/tclCompCmds.c107
-rw-r--r--generic/tclCompile.c4
-rw-r--r--generic/tclCompile.h8
-rw-r--r--generic/tclExecute.c18
-rw-r--r--tests/mathop.test7
6 files changed, 86 insertions, 66 deletions
diff --git a/ChangeLog b/ChangeLog
index 8eda2b4..909088f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,13 @@
2007-09-09 Don Porter <dgp@users.sourceforge.net>
+ * generic/tclCompCmds.c: Use the new INST_REVERSE instruction
+ * tests/mathop.test: to correct the compiled versions of math
+ operator commands. [Bug 1724437].
+
+ * generic/tclCompile.c: New bytecode instruction INST_REVERSE to
+ * generic/tclCompile.h: reverse the order of N items at the top of
+ * generic/tclExecute.c: stack.
+
* generic/tclCompCmds.c (TclCompilePowOpCmd): Make a separate
routine to compile ** to account for its different associativity.
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 6e1a683..dbf3301 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompCmds.c,v 1.117 2007/09/09 14:34:08 dgp Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.118 2007/09/09 16:51:18 dgp Exp $
*/
#include "tclInt.h"
@@ -4799,21 +4799,20 @@ CompileAssociativeBinaryOpCmd(
DefineLineInformation; /* TIP #280 */
int words;
- if (parsePtr->numWords == 1) {
+ for (words=1 ; words<parsePtr->numWords ; words++) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, words);
+ }
+ if (parsePtr->numWords <= 2) {
PushLiteral(envPtr, identity, -1);
- return TCL_OK;
+ words++;
}
- if (parsePtr->numWords == 2) {
+ if (words > 3) {
/*
- * TODO: Fixup the single argument case to require numeric argument.
- * Fallback on direct eval until fixed.
+ * Reverse order of arguments to get precise agreement with
+ * [expr] in calcuations, including roundoff errors.
*/
-
- return TCL_ERROR;
- }
- for (words=1 ; words<parsePtr->numWords ; words++) {
- tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, words);
+ TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
}
while (--words > 1) {
TclEmitOpcode(instruction, envPtr);
@@ -5042,6 +5041,10 @@ TclCompilePowOpCmd(
Tcl_Parse *parsePtr,
CompileEnv *envPtr)
{
+ /*
+ * This one has its own implementation because the ** operator is
+ * the only one with right associativity.
+ */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
DefineLineInformation; /* TIP #280 */
int words;
@@ -5178,29 +5181,6 @@ TclCompileStreqOpCmd(
return CompileComparisonOpCmd(interp, parsePtr, INST_STR_EQ, envPtr);
}
-/*
- * This is either clever or stupid.
- *
- * Note the rule: (a-b) = - (b-a)
- * And apply repeatedly to:
- *
- * (((a-b)-c)-d)
- * = - (d - ((a-b)-c))
- * = - (d - - (c - (a-b)))
- * = - (d - - (c - - (b - a)))
- * = - (d + (c + (b - a)))
- * = - ((d + c + b) - a)
- * = (a - (d + c + b))
- *
- * So after word compilation puts the substituted arguments on the stack in
- * reverse order, we don't have to turn them around again and apply repeated
- * INST_SUB instructions. Instead we keep them 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
TclCompileMinusOpCmd(
Tcl_Interp *interp,
@@ -5212,22 +5192,30 @@ TclCompileMinusOpCmd(
int words;
if (parsePtr->numWords == 1) {
+ /* Fallback to direct eval to report syntax error */
return TCL_ERROR;
}
- if (parsePtr->numWords == 2) {
- PushLiteral(envPtr, "0", -1);
- }
for (words=1 ; words<parsePtr->numWords ; words++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, words);
}
- if (parsePtr->numWords == 2) {
- words++;
+ if (words == 2) {
+ TclEmitOpcode(INST_UMINUS, envPtr);
+ return TCL_OK;
}
- while (--words > 2) {
- TclEmitOpcode(INST_ADD, envPtr);
+ if (words == 3) {
+ TclEmitOpcode(INST_SUB, envPtr);
+ return TCL_OK;
+ }
+ /*
+ * Reverse order of arguments to get precise agreement with
+ * [expr] in calcuations, including roundoff errors.
+ */
+ TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
+ while (--words > 1) {
+ TclEmitInstInt4(INST_REVERSE, 2, envPtr);
+ TclEmitOpcode(INST_SUB, envPtr);
}
- TclEmitOpcode(INST_SUB, envPtr);
return TCL_OK;
}
@@ -5237,31 +5225,32 @@ TclCompileDivOpCmd(
Tcl_Parse *parsePtr,
CompileEnv *envPtr)
{
- Tcl_Token *tokenPtr;
+ Tcl_Token *tokenPtr = parsePtr->tokenPtr;
DefineLineInformation; /* TIP #280 */
int words;
if (parsePtr->numWords == 1) {
+ /* Fallback to direct eval to report syntax error */
return TCL_ERROR;
- } else if (parsePtr->numWords == 2) {
+ }
+ if (parsePtr->numWords == 2) {
PushLiteral(envPtr, "1.0", 3);
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 1);
- TclEmitOpcode(INST_DIV, envPtr);
- return TCL_OK;
- } else {
- /*
- * TODO: get compiled version that passes mathop-6.18. For now,
- * fallback to direct evaluation.
- */
-
- return TCL_ERROR;
}
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 1);
- for (words=2 ; words<parsePtr->numWords ; words++) {
+ for (words=1 ; words<parsePtr->numWords ; words++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, words);
+ }
+ if (words <= 3) {
+ TclEmitOpcode(INST_DIV, envPtr);
+ return TCL_OK;
+ }
+ /*
+ * Reverse order of arguments to get precise agreement with
+ * [expr] in calcuations, including roundoff errors.
+ */
+ TclEmitInstInt4(INST_REVERSE, words-1, envPtr);
+ while (--words > 1) {
+ TclEmitInstInt4(INST_REVERSE, 2, envPtr);
TclEmitOpcode(INST_DIV, envPtr);
}
return TCL_OK;
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index fda8e9c..7ccf919 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.c,v 1.129 2007/08/30 19:24:32 dgp Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.130 2007/09/09 16:51:18 dgp Exp $
*/
#include "tclInt.h"
@@ -383,6 +383,8 @@ InstructionDesc tclInstructionTable[] = {
* index op1. Leaves the namespace on stack. */
{"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}},
/* Compiled bytecodes to signal syntax error. */
+ {"reverse", 5, +1, 1, {OPERAND_UINT4}},
+ /* Reverse the order of the arg elements at the top of stack */
{0}
};
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index ea975f9..50e2312 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.h,v 1.77 2007/08/28 16:24:31 dgp Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.78 2007/09/09 16:51:19 dgp Exp $
*/
#ifndef _TCLCOMPILATION
@@ -630,8 +630,12 @@ typedef struct ByteCode {
#define INST_SYNTAX 125
+/* Instruction to reverse N items on top of stack */
+
+#define INST_REVERSE 126
+
/* The last opcode */
-#define LAST_INST_OPCODE 125
+#define LAST_INST_OPCODE 126
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 87b1024..e133c55 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclExecute.c,v 1.330 2007/09/08 22:36:59 dkf Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.331 2007/09/09 16:51:19 dgp Exp $
*/
#include "tclInt.h"
@@ -1883,6 +1883,22 @@ TclExecuteByteCode(
NEXT_INST_F(5, 0, 1);
}
+ case INST_REVERSE: {
+ int opnd;
+ Tcl_Obj **a, **b;
+
+ opnd = TclGetUInt4AtPtr(pc+1);
+ a = tosPtr-(opnd-1);
+ b = tosPtr;
+ while (a<b) {
+ Tcl_Obj *temp = *a;
+ *a = *b;
+ *b = temp;
+ a++; b--;
+ }
+ NEXT_INST_F(5, 0, 0);
+ }
+
case INST_CONCAT1: {
int opnd, length, appendLen = 0;
char *bytes, *p;
diff --git a/tests/mathop.test b/tests/mathop.test
index c3888cb..8bbebd9 100644
--- a/tests/mathop.test
+++ b/tests/mathop.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: mathop.test,v 1.8 2007/05/18 18:39:31 dgp Exp $
+# RCS: @(#) $Id: mathop.test,v 1.9 2007/09/09 16:51:19 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
@@ -793,13 +793,14 @@ test mathop-20.7 { multi arg } {
} [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 vals {{1.0 2} {3.0 4 5} {4 3.0 2 1}
+ {1.0 -1.0 1e-18} {1.0 1.0 1e-18}} {
foreach op {+ - * /} {
lappend res [TestOp $op {*}$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}]]
+} [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}] 1e-18 2.0 -1e-18 [expr {-1.0/1e-18}] 2.0 -1e-18 1e-18 [expr {1.0/1e-18}]]
test mathop-21.1 { unary ops, bitnot } {
set res {}
generated by cgit v0.12 at 2024-07-05 05:52:17 (GMT)