summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKevin B Kenny <kennykb@acm.org>2010-09-27 03:08:12 (GMT)
committerKevin B Kenny <kennykb@acm.org>2010-09-27 03:08:12 (GMT)
commitb5bc78c17be16102c70991d3090dc85aa9baf44b (patch)
treea98672f9bc6e035c276c3171d49657436dff14c1
parentb11a98cb21d914b16a8d9761101bdb366084cc48 (diff)
downloadtcl-b5bc78c17be16102c70991d3090dc85aa9baf44b.zip
tcl-b5bc78c17be16102c70991d3090dc85aa9baf44b.tar.gz
tcl-b5bc78c17be16102c70991d3090dc85aa9baf44b.tar.bz2
* 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.
-rw-r--r--ChangeLog9
-rw-r--r--generic/tclAssembly.c59
-rw-r--r--tests/assemble.test472
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 {