* tests/assemble.test: Added more "white box" tests.

* generic/tclAssembly.c: Fixed bugs exposed by the new tests.
(a) [eval] and [expr] had incorrect stack balance computed if
the arg was not a simple word. (b) [concat] accepted a negative
operand count. (c) [invoke] accepted a zero or negative operand
count. (d) more misspelt error messages.

3 files changed, 510 insertions, 30 deletions

diff --git a/ChangeLog b/ChangeLog
index bc2c4da..7aa9888 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2010-09-27  Kevin B. Kenny  <kennykb@acm.org>
+
+	* tests/assemble.test: Added more "white box" tests.
+	* generic/tclAssembly.c: Fixed bugs exposed by the new tests.
+	(a) [eval] and [expr] had incorrect stack balance computed if
+	the arg was not a simple word. (b) [concat] accepted a negative
+	operand count. (c) [invoke] accepted a zero or negative operand
+	count. (d) more misspelt error messages.
+
 2010-09-26  Kevin B. Kenny  <kennykb@acm.org>
 
 	* tests/assemble.test:	Added many new tests moving toward a more
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index c83f5d6..660f101 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -50,6 +50,7 @@ static int CheckNamespaceQualifiers(Tcl_Interp*, const char*, int);
 static int CheckOneByte(Tcl_Interp*, int);
 static int CheckSignedOneByte(Tcl_Interp*, int);
 static int CheckStack(AssembleEnv*);
+static int CheckStrictlyPositive(Tcl_Interp*, int);
 static ByteCode * CompileAssembleObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
 static int DefineLabel(AssembleEnv* envPtr, const char* label);
 static void DupAssembleCodeInternalRep(Tcl_Obj* src, Tcl_Obj* dest);
@@ -130,7 +131,7 @@ talInstDesc talInstructionTable[] = {
     {"div",     ASSEM_1BYTE,    INST_DIV,       2,      1},
     {"dup",     ASSEM_1BYTE ,   INST_DUP    ,   1   ,   2}, 
     {"eq",      ASSEM_1BYTE ,   INST_EQ     ,   2   ,   1},
-    {"eval",	ASSEM_EVAL,	INST_EVAL_STK,	0,	1},
+    {"eval",	ASSEM_EVAL,	INST_EVAL_STK,	1,	1},
     {"evalStk",	ASSEM_1BYTE,	INST_EVAL_STK,	1,	1},
     {"exist",	ASSEM_LVT4,	INST_EXIST_SCALAR,
                                                 0,      1},
@@ -143,7 +144,7 @@ talInstDesc talInstructionTable[] = {
     {"existStk",
 		ASSEM_1BYTE,	INST_EXIST_STK,	1,	1},
     {"expon",   ASSEM_1BYTE,    INST_EXPON,     2,      1},
-    {"expr",	ASSEM_EVAL,	INST_EXPR_STK,	0,	1},
+    {"expr",	ASSEM_EVAL,	INST_EXPR_STK,	1,	1},
     {"exprStk", ASSEM_1BYTE,	INST_EXPR_STK,	1,	1},
     {"ge",      ASSEM_1BYTE ,   INST_GE     ,   2   ,   1},
     {"gt",      ASSEM_1BYTE ,   INST_GT     ,   2   ,   1},
@@ -1023,15 +1024,8 @@ AssembleOneLine(AssembleEnv* assemEnvPtr)
 	    goto cleanup;
 	}
 	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
-	    || CheckOneByte(interp, opnd) != TCL_OK) {
-	    goto cleanup;
-	}
-	if (opnd == 0) {
-	    if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
-		Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot concatenate "
-							  "zero objects", -1));
-		Tcl_SetErrorCode(interp, "TCL", "ASSEM", "EMPTYCONCAT", NULL);
-	    }
+	    || CheckOneByte(interp, opnd) != TCL_OK
+	    || CheckStrictlyPositive(interp, opnd) != TCL_OK) {
 	    goto cleanup;
 	}
 	BBEmitInstInt1(assemEnvPtr, tblind, opnd, opnd);
@@ -1093,10 +1087,11 @@ AssembleOneLine(AssembleEnv* assemEnvPtr)
 	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
 	    goto cleanup;
 	}
-	if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK
-	    || Tcl_GetIntFromObj(interp, operand1Obj, &opnd) != TCL_OK) {
+	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
+	    || CheckStrictlyPositive(interp, opnd) != TCL_OK) {
 	    goto cleanup;
 	}
+	
 	BBEmitInst1or4(assemEnvPtr, tblind, opnd, opnd);
 	break;
 		 
@@ -1583,7 +1578,7 @@ CheckOneByte(Tcl_Interp* interp,
     if (value < 0 || value > 0xff) {
 	result = Tcl_NewStringObj("operand does not fit in one byte", -1);
 	Tcl_SetObjResult(interp, result);
-	Tcl_SetErrorCode(interp, "TCL", "ASSEMBLE", "1BYTE", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL);
 	return TCL_ERROR;
     }
     return TCL_OK;
@@ -1615,9 +1610,41 @@ CheckSignedOneByte(Tcl_Interp* interp,
 {
     Tcl_Obj* result;		/* Error message */
     if (value > 0x7f || value < -0x80) {
-	result = Tcl_NewStringObj("operand does not fit in 1 byte", -1);
+	result = Tcl_NewStringObj("operand does not fit in one byte", -1);
+	Tcl_SetObjResult(interp, result);
+	Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL);
+	return TCL_ERROR;
+    }
+    return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * CheckStrictlyPositive --
+ *
+ *	Verify that a constant is positive
+ *
+ * Results:
+ *	On success, returns TCL_OK. On failure, returns TCL_ERROR and
+ *	stores an error message in the interpreter result.
+ *
+ * This code is here primarily to verify that instructions like INCR_INVOKE
+ * are consuming a positive number of operands
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+CheckStrictlyPositive(Tcl_Interp* interp,
+				/* Tcl interpreter for error reporting */
+		      int value)	/* Value to check */
+{
+    Tcl_Obj* result;		/* Error message */
+    if (value <= 0) {
+	result = Tcl_NewStringObj("operand must be positive", -1);
 	Tcl_SetObjResult(interp, result);
-	Tcl_SetErrorCode(interp, "TCL", "ASSEMBLE", "1BYTE", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "ASSEM", "POSITIVE", NULL);
 	return TCL_ERROR;
     }
     return TCL_OK;
diff --git a/tests/assemble.test b/tests/assemble.test
index 3263002..1dc1ed9 100644
--- a/tests/assemble.test
+++ b/tests/assemble.test
@@ -797,19 +797,6 @@ test assemble-7.40 {uplus} {
     -result 42
 }
 
-test assemble-7.8 {exist} {
-    -body {
-	proc x {} {
-	    set y z
-	    list [assemble {exist y}] \
-		[assemble {exist z}]
-	}
-	x
-    }
-    -result {1 0}
-    -cleanup {rename x {}}
-}
-
 # assemble-8 ASSEM_LVT and FindLocalVar
 
 test assemble-8.1 {load, wrong # args} {
@@ -1129,10 +1116,467 @@ test assemble-9.7 {concat} {
     -body {
 	list [catch {assemble {concat 0}} result] $result $::errorCode
     }
-    -result {1 {cannot concatenate zero objects} {TCL ASSEM EMPTYCONCAT}}
+    -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
+    -cleanup {unset result}
+}
+
+# assemble-10 -- eval and expr
+
+test assemble-10.1 {eval - wrong # args} {
+    -body {
+	assemble {eval}
+    }
+    -returnCodes error
+    -match glob
+    -result {wrong # args*}
+}
+
+test assemble-10.2 {eval - wrong # args} {
+    -body {
+	assemble {eval too many}
+    }
+    -returnCodes error
+    -match glob
+    -result {wrong # args*}
+}
+
+test assemble-10.3 {eval} {
+    -body {
+	proc x {} {
+	    assemble {
+		push 3
+		store n
+		pop
+		eval {expr {3*$n + 1}}
+		push 1
+		add
+	    }
+	}
+	x
+    }
+    -result 11
+    -cleanup {rename x {}}
+}
+
+test assemble-10.4 {expr} {
+    -body {
+	proc x {} {
+	    assemble {
+		push 3
+		store n
+		pop
+		expr {3*$n + 1}
+		push 1
+		add
+	    }
+	}
+	x
+    }
+    -result 11
+    -cleanup {rename x {}}
+}
+
+test assemble-10.5 {eval and expr - nonsimple} {
+    -body {
+	proc x {} {
+	    assemble {
+		eval "s\x65t n 3"
+		pop
+		expr "\x33*\$n + 1"
+		push 1
+		add
+	    }
+	}
+	x
+    }
+    -result 11
+    -cleanup {
+	rename x {}
+    }
+}
+
+test assemble-10.6 {eval - noncompilable} {
+    -body {
+	list [catch {assemble {eval $x}} result] $result $::errorCode
+    }
+    -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
+}
+
+test assemble-10.7 {expr - noncompilable} {
+    -body {
+	list [catch {assemble {expr $x}} result] $result $::errorCode
+    }
+    -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
+}
+
+# assemble-11 - ASSEM_LVT4 (exist and existArray)
+		
+test assemble-11.1 {exist - wrong # args} {
+    -body {
+	assemble {exist}
+    }
+    -returnCodes error
+    -match glob
+    -result {wrong # args*}
+}
+
+test assemble-11.2 {exist - wrong # args} {
+    -body {
+	assemble {exist too many}
+    }
+    -returnCodes error
+    -match glob
+    -result {wrong # args*}
+}
+
+test assemble-11.3 {nonlocal var} {
+    -body {
+	list [catch {assemble {exist ::env}} result] $result $errorCode
+    }
+    -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}}
+    -cleanup {unset result}
+}
+
+test assemble-11.4 {exist} {
+    -body {
+	proc x {} {
+	    set y z
+	    list [assemble {exist y}] \
+		[assemble {exist z}]
+	}
+	x
+    }
+    -result {1 0}
+    -cleanup {rename x {}}
+}
+
+test assemble-11.5 {existArray} {
+    -body {
+	proc x {} {
+	    set a(b) c
+	    list [assemble {push b; existArray a}] \
+		[assemble {push c; existArray a}] \
+		[assemble {push a; existArray b}]
+	}
+	x
+    }
+    -result {1 0 0}
+    -cleanup {rename x {}}
+}
+
+# assemble-12 - ASSEM_LVT1 (incr and incrArray)
+		
+test assemble-12.1 {incr - wrong # args} {
+    -body {
+	assemble {incr}
+    }
+    -returnCodes error
+    -match glob
+    -result {wrong # args*}
+}
+
+test assemble-12.2 {incr - wrong # args} {
+    -body {
+	assemble {incr too many}
+    }
+    -returnCodes error
+    -match glob
+    -result {wrong # args*}
+}
+
+test assemble-12.3 {incr nonlocal var} {
+    -body {
+	list [catch {assemble {incr ::env}} result] $result $errorCode
+    }
+    -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}}
+    -cleanup {unset result}
+}
+
+test assemble-12.4 {incr} {
+    -body {
+	proc x {} {
+	    set y 5
+	    assemble {push 3; incr y}
+	}
+	x
+    }
+    -result 8
+    -cleanup {rename x {}}
+}
+
+test assemble-12.5 {incrArray} {
+    -body {
+	proc x {} {
+	    set a(b) 5
+	    assemble {push b; push 3; incrArray a}
+	}
+	x
+    }
+    -result 8
+    -cleanup {rename x {}}
+}
+
+test assemble-12.6 {incr, stupid stack restriction} {
+    -body {
+	proc x {} "
+	    [fillTables]
+            set y 5
+            assemble {push 3; incr y}
+        "
+	list [catch {x} result] $result $errorCode
+    }
+    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
+    -cleanup {unset result; rename x {}}
+}
+
+# assemble-13 -- ASSEM_LVT1_SINT1 - incrImm and incrArrayImm
+
+test assemble-13.1 {incrImm - wrong # args} {
+    -body {
+	assemble {incrImm x}
+    }
+    -returnCodes error
+    -match glob
+    -result {wrong # args*}
+}
+
+test assemble-13.2 {incrImm - wrong # args} {
+    -body {
+	assemble {incrImm too many args}
+    }
+    -returnCodes error
+    -match glob
+    -result {wrong # args*}
+}
+
+test assemble-13.3 {incrImm nonlocal var} {
+    -body {
+	list [catch {assemble {incrImm ::env 2}} result] $result $errorCode
+    }
+    -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}}
     -cleanup {unset result}
 }
 
+test assemble-13.4 {incrImm not a number} {
+    -body {
+	proc x {} {
+	    assemble {incrImm x rubbish}
+	}
+	x
+    }
+    -returnCodes error
+    -result {expected integer but got "rubbish"}
+    -cleanup {rename x {}}
+}
+
+test assemble-13.5 {incrImm too big} {
+    -body {
+	proc x {} {
+	    assemble {incrImm x 0x80}
+	}
+	list [catch x result] $result $::errorCode
+    }
+    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
+    -cleanup {rename x {}; unset result}
+}
+    
+test assemble-13.6 {incrImm too small} {
+    -body {
+	proc x {} {
+	    assemble {incrImm x -0x81}
+	}
+	list [catch x result] $result $::errorCode
+    }
+    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
+    -cleanup {rename x {}; unset result}
+}
+
+test assemble-13.7 {incrImm} {
+    -body {
+	proc x {} {
+	    set y 1
+	    list [assemble {incrImm y -0x80}] [assemble {incrImm y 0x7f}]
+	}
+	x
+    }
+    -result {-127 0}
+    -cleanup {rename x {}}
+}
+
+test assemble-13.8 {incrArrayImm} {
+    -body {
+	proc x {} {
+	    set a(b) 5
+	    assemble {push b; incrArrayImm a 3}
+	}
+	x
+    }
+    -result 8
+    -cleanup {rename x {}}
+}
+
+test assemble-13.9 {incrImm, stupid stack restriction} {
+    -body {
+	proc x {} "
+	    [fillTables]
+            set y 5
+            assemble {incrImm y 3}
+        "
+	list [catch {x} result] $result $errorCode
+    }
+    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
+    -cleanup {unset result; rename x {}}
+}
+
+# assemble-14 -- ASSEM_SINT1 (incrArrayStkImm and incrStkImm)
+
+test assemble-14.1 {incrStkImm - wrong # args} {
+    -body {
+	assemble {incrStkImm}
+    }
+    -returnCodes error
+    -match glob
+    -result {wrong # args*}
+}
+
+test assemble-14.2 {incrStkImm - wrong # args} {
+    -body {
+	assemble {incrStkImm too many}
+    }
+    -returnCodes error
+    -match glob
+    -result {wrong # args*}
+}
+
+test assemble-14.3 {incrStkImm not a number} {
+    -body {
+	proc x {} {
+	    assemble {incrStkImm rubbish}
+	}
+	x
+    }
+    -returnCodes error
+    -result {expected integer but got "rubbish"}
+    -cleanup {rename x {}}
+}
+
+test assemble-14.4 {incrStkImm too big} {
+    -body {
+	proc x {} {
+	    assemble {incrStkImm 0x80}
+	}
+	list [catch x result] $result $::errorCode
+    }
+    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
+    -cleanup {rename x {}; unset result}
+}
+    
+test assemble-14.5 {incrStkImm too small} {
+    -body {
+	proc x {} {
+	    assemble {incrStkImm -0x81}
+	}
+	list [catch x result] $result $::errorCode
+    }
+    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
+    -cleanup {rename x {}; unset result}
+}
+
+test assemble-14.6 {incrStkImm} {
+    -body {
+	proc x {} {
+	    set y 1
+	    list [assemble {push y; incrStkImm -0x80}] \
+		[assemble {push y; incrStkImm 0x7f}]
+	}
+	x
+    }
+    -result {-127 0}
+    -cleanup {rename x {}}
+}
+
+test assemble-14.7 {incrArrayStkImm} {
+    -body {
+	proc x {} {
+	    set a(b) 5
+	    assemble {push a; push b; incrArrayStkImm 3}
+	}
+	x
+    }
+    -result 8
+    -cleanup {rename x {}}
+}
+
+# assemble-15 - invokeStk
+
+test assemble-15.1 {invokeStk - wrong # args} {
+    -body {
+	assemble {invokeStk}
+    }
+    -returnCodes error
+    -match glob
+    -result {wrong # args*}
+}
+
+test assemble-15.2 {invokeStk - wrong # args} {
+    -body {
+	assemble {invokeStk too many}
+    }
+    -returnCodes error
+    -match glob
+    -result {wrong # args*}
+}
+
+test assemble-15.3 {invokeStk - not a number} {
+    -body {
+	proc x {} {
+	    assemble {invokeStk rubbish}
+	}
+	x
+    }
+    -returnCodes error
+    -result {expected integer but got "rubbish"}
+    -cleanup {rename x {}}
+}
+
+test assemble-15.4 {invokeStk - no operands} {
+    -body {
+	proc x {} {
+	    assemble {invokeStk 0}
+	}
+	list [catch x result] $result $::errorCode
+    }
+    -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
+    -cleanup {rename x {}; unset result}
+}
+
+test assemble-15.5 {invokeStk1} {
+    -body {
+	tcl::unsupported::assemble {push concat; push 1; push 2; invokeStk 3}
+    }
+    -result {1 2}
+}
+
+test assemble-15.6 {invokeStk4} {
+    -body {
+	proc x {n} {
+	    set code {push concat}
+	    set shouldbe {}
+	    for {set i 1} {$i < $n} {incr i} {
+		append code \n {push a} $i
+		lappend shouldbe a$i
+	    }
+	    append code \n {invokeStk} { } $n
+	    set is [assemble $code]
+	    expr {$is eq $shouldbe}
+	}
+	list [x 254] [x 255] [x 256] [x 257]
+    }
+    -result {1 1 1 1}
+    -cleanup {rename x {}}
+}
+
+
 test assemble-1.6 {Testing push, dup, add} {
     -body { 
 	assemble {