merge updates from HEAD

6 files changed, 104 insertions, 70 deletions

diff --git a/ChangeLog b/ChangeLog
index 29e4b78..fa0d808 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,16 @@
+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.
+
 2007-09-08  Miguel Sofer  <msofer@users.sf.net>
 
 	* generic/tclVar.c (Tcl_SetVar2, TclPtrSetVar): [Bug 1710710]
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 585224d..28c0fdb 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.109.2.5 2007/09/04 17:43:49 dgp Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.109.2.6 2007/09/09 17:26:34 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);
@@ -5043,12 +5042,25 @@ TclCompilePowOpCmd(
     CompileEnv *envPtr)
 {
     /*
-     * The ** operator isn't associative, but the right to left calculation
-     * order of the called routine is correct.
+     * 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;
 
-    return CompileAssociativeBinaryOpCmd(interp, parsePtr, "1", INST_EXPON,
-	    envPtr);
+    for (words=1 ; words<parsePtr->numWords ; words++) {
+	tokenPtr = TokenAfter(tokenPtr);
+	CompileWord(envPtr, tokenPtr, interp, words);
+    }
+    if (parsePtr->numWords <= 2) {
+	PushLiteral(envPtr, "1", 1);
+	words++;
+    }
+    while (--words > 1) {
+	TclEmitOpcode(INST_EXPON, envPtr);
+    }
+    return TCL_OK;
 }
 
 int
@@ -5169,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,
@@ -5203,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;
 }
 
@@ -5228,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 45b534d..bc1715e 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.117.2.7 2007/09/04 17:43:49 dgp Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.117.2.8 2007/09/09 17:26:35 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,    0,         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 9e65d45..49d19d2 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.70.2.5 2007/09/04 17:43:50 dgp Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.70.2.6 2007/09/09 17:26:35 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 7dcc31f..c4e1449 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.285.2.14 2007/09/09 04:14:28 dgp Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.285.2.15 2007/09/09 17:26:38 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..6bc86dc 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.8.2.1 2007/09/09 17:26:39 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 {}