diff options
| -rw-r--r-- | ChangeLog | 9 | ||||
| -rw-r--r-- | generic/tclAssembly.c | 59 | ||||
| -rw-r--r-- | tests/assemble.test | 472 |
3 files changed, 510 insertions, 30 deletions
@@ -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 { |