From d99cc083620428efefa6cbe365862a1744e29920 Mon Sep 17 00:00:00 2001 From: Kevin B Kenny Date: Wed, 29 Sep 2010 03:10:31 +0000 Subject: * tests/assemble.test: Completed conversion of tests to a * generic/tclAssemble.c: "white box" structure that follows the C code. Added missing safety checks on the operands of 'over' and 'reverse' so that negative operand counts don't smash the stack. --- ChangeLog | 9 + generic/tclAssembly.c | 39 ++- tests/assemble.test | 862 ++++++++++++++++++++++---------------------------- 3 files changed, 427 insertions(+), 483 deletions(-) diff --git a/ChangeLog b/ChangeLog index f58e598..a362cbf 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +2010-09-29 Kevin B. Kenny + + [dogeen-assembler-branch] + + * tests/assemble.test: Completed conversion of tests to a + * generic/tclAssemble.c: "white box" structure that follows the + C code. Added missing safety checks on the operands of 'over' and + 'reverse' so that negative operand counts don't smash the stack. + 2010-09-28 Reinhard Max Implementation of TIP #162, "IPv6 Sockets for Tcl" diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 899d419..d6916fa 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -18,6 +18,7 @@ static void BBEmitInst1or4(AssembleEnv* assemEnvPtr, int tblind, int param, int count); static void BBEmitOpcode(AssembleEnv* assemEnvPtr, int tblind, int count); static int CheckNamespaceQualifiers(Tcl_Interp*, const char*, int); +static int CheckNonNegative(Tcl_Interp*, int); static int CheckOneByte(Tcl_Interp*, int); static int CheckSignedOneByte(Tcl_Interp*, int); static int CheckStack(AssembleEnv*); @@ -1170,7 +1171,8 @@ AssembleOneLine(AssembleEnv* assemEnvPtr) Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckNonNegative(interp, opnd) != TCL_OK) { goto cleanup; } BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd+1); @@ -1181,7 +1183,8 @@ AssembleOneLine(AssembleEnv* assemEnvPtr) Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckNonNegative(interp, opnd) != TCL_OK) { goto cleanup; } BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd); @@ -1582,6 +1585,38 @@ CheckSignedOneByte(Tcl_Interp* interp, /* *----------------------------------------------------------------------------- * + * CheckNonNegative -- + * + * Verify that a constant is nonnegative + * + * 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 +CheckNonNegative(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 nonnegative", -1); + Tcl_SetObjResult(interp, result); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONNEGATIVE", NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * * CheckStrictlyPositive -- * * Verify that a constant is positive diff --git a/tests/assemble.test b/tests/assemble.test index 0038346..03f329a 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -1806,634 +1806,534 @@ test assemble-16.14 {jump to undefined label, line number correct?} { -match glob -result {*"assemble" body, line 4*} } - -test assemble-1.6 {Testing push, dup, add} { - -body { - assemble { - push 2 - dup - add - } - } - -result {4} -} +# assemble-17 - over -test assemble-1.6a {wrong # args} { +test assemble-17.1 {over - wrong # args} { -body { - catch { - assemble { - push 2 2 - dup - add - } - } - set ::errorInfo + assemble {over} } + -returnCodes error -match glob - -result {wrong # args: should be "push value" - while executing -"push 2 2" - ("assemble" body, line 2)* - } + -result {wrong # args*} } -test assemble-1.7 {longer sequence} { +test assemble-17.2 {over - wrong # args} { -body { - assemble { - push 3 - dup - mult - push 4 - dup - mult - expon - } + assemble {over too many} } - -result {1853020188851841} + -returnCodes error + -match glob + -result {wrong # args*} } -test assemble-1.8 {unbalanced stack} { +test assemble-17.3 {over - bad subst} { -body { - list \ - [catch { - assemble { - push 3 - dup - mult - push 4 - dup - mult - pop - expon - } - } result] $result $::errorInfo + assemble {over $foo} } - -result {1 {stack underflow} {stack underflow - in assembly code between lines 1 and end of assembly code*}} + -returnCodes error -match glob - -returnCodes ok + -result {assembly code may not contain substitutions} } -test assemble-1.8a {unbalanced stack} {*}{ +test assemble-17.4 {over - not a number} { -body { - list \ - [catch { - assemble { - label a - push {} - label b - pop - label c - pop - label d - push {} - } - } result] $result $::errorInfo + proc x {} { + assemble {over rubbish} + } + x } - -result {1 {stack underflow} {stack underflow - in assembly code between lines 7 and 8*}} - -match glob - -returnCodes ok + -returnCodes error + -result {expected integer but got "rubbish"} + -cleanup {rename x {}} } -# Tests for load and store - -test assemble-1.9 { Testing load within a proc } { - -body { - proc x y { - assemble { - load y - dup - mult - } +test assemble-17.5 {over - negative operand count} { + -body { + proc x {} { + assemble {over -1} } - x 10 + list [catch x result] $result $::errorCode } - -result {100} + -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}} + -cleanup {rename x {}; unset result} } -test assemble-1.10 {store and load again} { - -body { - proc x arg { +test assemble-17.6 {over} { + -body { + proc x {} { assemble { - push aString - store arg + push 1 + push 2 + push 3 + over 0 + store x + pop + pop pop - load arg - } - } - x "not_aString" + pop + load x + } + } + x } - -result {aString} + -result 3 + -cleanup {rename x {}} } -test assemble-1.11 {Testing storeArray and loadArray} { - -body { - set anArray(1,2) "not_aString" - proc x arg { - upvar $arg anArray +test assemble-17.7 {over} { + -body { + proc x {} { assemble { - push 1,2 - push aString - storeArray anArray + push 1 + push 2 + push 3 + over 2 + store x + pop + pop + pop pop - push 1,2 - loadArray anArray - } + load x + } } - x anArray + x } - -cleanup {unset anArray} - -result {aString} + -result 1 + -cleanup {rename x {}} } -test assemble-1.12 {Testing loadStk with a variable} { - -body { - set vara 10 - assemble { - push vara - loadStk - dup - mult - push 4 - dup - mult - add - } +# assemble-18 - reverse + +test assemble-18.1 {reverse - wrong # args} { + -body { + assemble {reverse} } - -cleanup {unset vara} - -result {116} + -returnCodes error + -match glob + -result {wrong # args*} } -test assemble-1.13 {Testing loadStk with an array variable} { - -body { - set vararr(1,2) 10 - assemble { - push vararr(1,2) - loadStk - dup - mult - push 4 - dup - mult - add - } +test assemble-18.2 {reverse - wrong # args} { + -body { + assemble {reverse too many} } - -cleanup {unset vararr} - -result {116} + -returnCodes error + -match glob + -result {wrong # args*} } -test assemble-1.14 {Testing loadStk and storeStk} { +test assemble-18.3 {reverse - bad subst} { -body { - set aVar 5 - assemble { - push aVar - push aString - storeStk - pop - push aVar - loadStk - } + assemble {reverse $foo} } - -cleanup {unset aVar} - -result {aString} + -returnCodes error + -match glob + -result {assembly code may not contain substitutions} } -test assemble-1.15 {Testing loadArrayStk and storeArrayStk} { - -body { - set aVar(1,2) 5 - assemble { - push aVar - push 1,2 - push aString - storeArrayStk - pop - push aVar - push 1,2 - loadArrayStk +test assemble-18.4 {reverse - not a number} { + -body { + proc x {} { + assemble {reverse rubbish} } + x } - -cleanup {unset aVar} - -result {aString} + -returnCodes error + -result {expected integer but got "rubbish"} + -cleanup {rename x {}} } -# Tests for incr instructions - -test assemble-1.16 { Testing incr } { +test assemble-18.5 {reverse - negative operand count} { -body { - proc x arg { - set i 5 - assemble { - push 5 - incr i - } + proc x {} { + assemble {reverse -1} } - x 1 + list [catch x result] $result $::errorCode } - -result {10} + -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}} + -cleanup {rename x {}; unset result} } -test assemble-1.17 { Testing incrImm } { - -body { - proc x arg { - set i 5 - assemble { - incrImm i 5 - } - } - x 1 +test assemble-18.6 {reverse - zero operand count} { + -body { + proc x {} { + assemble {push 1; reverse 0} + } + x } - -result {10} + -result 1 + -cleanup {rename x {}} } -test assemble-1.18 { Testing incrStk } { +test assemble-18.7 {reverse} { -body { - proc x arg { - set i 5 + proc x {} { assemble { - push i - push 5 - incrStk + push 1 + push 2 + push 3 + reverse 1 + store x + pop + pop + pop + load x } } - x 1 + x } - -result {10} + -result 3 + -cleanup {rename x {}} } -test assemble-1.19 { Testing incrStkImm } { +test assemble-18.8 {reverse} { -body { - proc x arg { - set i 5 + proc x {} { assemble { - push i - incrStkImm 5 + push 1 + push 2 + push 3 + reverse 3 + store x + pop + pop + pop + load x } - } - x 1 + } + x } - -result {10} + -result 1 + -cleanup {rename x {}} } -test assemble-1.20 { Testing incrStkImm } { +# assemble-19 - ASSEM_BOOL (strmatch, unsetStk, unsetArrayStk) + +test assemble-19.1 {strmatch - wrong # args} { -body { - proc x arg { - set i 5 - assemble { - push i - incrStkImm 5 - } - } - x 1 + assemble {strmatch} } - -result {10} + -returnCodes error + -match glob + -result {wrong # args*} } -test assemble-1.21 { Testing incrArray } { +test assemble-19.2 {strmatch - wrong # args} { -body { - proc x arg { - set i(1,2) 5 - assemble { - push 1,2 - push 5 - incrArray i - } - } - x 1 + assemble {strmatch too many} } - -result {10} + -returnCodes error + -match glob + -result {wrong # args*} } -test assemble-1.22 { Testing incrArrayImm } { - -body { - proc x arg { - set i(1,2) 5 - assemble { - push 1,2 - incrArrayImm i 5 - } - } - x 1 +test assemble-19.3 {strmatch - bad subst} { + -body { + assemble {strmatch $foo} } - -result {10} + -returnCodes error + -match glob + -result {assembly code may not contain substitutions} } -test assemble-1.23 { Testing incrArrayStk } { +test assemble-18.4 {strmatch - not a boolean} { -body { - proc x arg { - set i(1,2) 5 - assemble { - push i - push 1,2 - push 5 - incrArrayStk - } - } - x 1 + proc x {} { + assemble {strmatch rubbish} + } + x } - -result {10} + -returnCodes error + -result {expected boolean value but got "rubbish"} + -cleanup {rename x {}} } -test assemble-1.24 { Testing incrArrayStkImm } { +test assemble-18.5 {strmatch} { -body { - proc x arg { - set i(1,2) 5 - assemble { - push i - push 1,2 - incrArrayStkImm 5 - } - } - x 1 + proc x {a b} { + list [assemble {load a; load b; strmatch 0}] \ + [assemble {load a; load b; strmatch 1}] + } + list [x foo*.grill fengbar.grill] [x foo*.grill foobar.grill] [x foo*.grill FOOBAR.GRILL] } - -result {10} + -result {{0 0} {1 1} {0 1}} + -cleanup {rename x {}} } -# Tests for STRs -NOT HERE YET -# Tests for LIST BYTECODES -NOT HERE YET - -# Tests for label and jump {push NotEqual} - -test assemble-1.25 { Testing label and jumpTrue } { - -body { - proc x {arg1 arg2} { - assemble { - label a - load arg2 - push 2 - mult - store arg2 - pop - load arg1 - push 1 - sub - store arg1 - push 0 - neq - jumpTrue a - load arg2 - } - } - x 4 2 - } - -result {32} -} - -test assemble-1.26 { Testing label and jumpFalse } { - -body { - proc x {arg1 arg2} { - assemble { - label a - load arg2 - push 2 - mult - store arg2 - pop - load arg1 - push 1 - sub - store arg1 - push 0 - eq - jumpFalse a - load arg2 - } - } - x 4 2 +test assemble-18.6 {unsetStk} { + -body { + proc x {} { + set a {} + assemble {push a; unsetStk false} + info exists a + } + x } - -result {32} + -result 0 + -cleanup {rename x {}} } -test assemble-1.27 {forward jumps} { - -body { - proc x {arg1 arg2 arg3} { - assemble { - jump a - push aString - store arg1 - pop - label a - jump b - push aString - store arg2 - label b - jump c - push aString - store arg3 - label c - load arg1 - } +test assemble-18.7 {unsetStk} { + -body { + proc x {} { + assemble {push a; unsetStk false} + info exists a } - x 1 2 3 + x } - -result {1} + -result 0 + -cleanup {rename x {}} } - -test assemble-1.28 {forward jumps} { - -body { - proc x {arg1 arg2 arg3} { - assemble { - jump a - push aString - store arg1 - pop - label a - jump b - push aString - store arg2 - label b - jump c - push aString - store arg3 - label c - load arg2 - } +test assemble-18.8 {unsetStk} { + -body { + proc x {} { + assemble {push a; unsetStk true} + info exists a } - x 1 2 3 + x } - -result {2} + -returnCodes error + -result {can't unset "a": no such variable} + -cleanup {rename x {}} } -test assemble-1.29 {forward jumps} { - -body { - proc x {arg1 arg2 arg3} { - assemble { - jump a - push aString - store arg1 - pop - label a - jump b - push aString - store arg2 - label b - jump c - push aString - store arg3 - label c - load arg3 - } +test assemble-18.9 {unsetArrayStk} { + -body { + proc x {} { + set a(b) {} + assemble {push a; push b; unsetArrayStk false} + info exists a(b) } - x 1 2 3 + x } - -result {3} + -result 0 + -cleanup {rename x {}} } -test assemble-1.30 {Inconsistent stack usage} {*}{ +test assemble-18.10 {unsetArrayStk} { -body { - proc x {y} { - assemble { - load y - jumpFalse else - push 0 - jump then - label else - push 1 - push 2 - label then - pop - } + proc x {} { + assemble {push a; push b; unsetArrayStk false} + info exists a(b) } - catch {x 1} - set errorInfo + x } - -match glob - -result {inconsistent stack depths on two execution paths - ("assemble" body, line 10)*} + -result 0 + -cleanup {rename x {}} } - -test assemble-1.31 {unset, exists, lappend - smoke test} { +test assemble-18.11 {unsetArrayStk} { -body { - proc x {y} { - assemble { - exist result - store result - pop - - exist result - lappend result - pop - - push result - push y - existStk - lappendStk - pop + proc x {} { + assemble {push a; push b; unsetArrayStk true} + info exists a(b) + } + x + } + -returnCodes error + -result {can't unset "a(b)": no such variable} + -cleanup {rename x {}} +} - push y - unsetStk true - exist y - lappend result - pop +# assemble-19 -- ASSEM_BOOL_LVT4 (unset; unsetArray) - push {} - store foo - pop - exist foo - lappend result - pop +test assemble-19.1 {unset - wrong # args} { + -body { + assemble {unset one} + } + -returnCodes error + -match glob + -result {wrong # args*} +} - unset true foo - exist foo - lappend result - pop +test assemble-19.2 {unset - wrong # args} { + -body { + assemble {unset too many args} + } + -returnCodes error + -match glob + -result {wrong # args*} +} - push a - existArray z - lappend result - pop +test assemble-19.3 {unset - bad subst -arg 1} { + -body { + assemble {unset $foo bar} + } + -returnCodes error + -match glob + -result {assembly code may not contain substitutions} +} - push a - push b - lappendArray z - lappend result - pop +test assemble-19.4 {unset - not a boolean} { + -body { + proc x {} { + assemble {unset rubbish trash} + } + x + } + -returnCodes error + -result {expected boolean value but got "rubbish"} + -cleanup {rename x {}} +} - push z - push a - existArrayStk - lappend result - pop +test assemble-19.5 {unset - bad subst - arg 2} { + -body { + assemble {unset true $bar} + } + -returnCodes error + -result {assembly code may not contain substitutions} +} - push z - push a - push c - lappendArrayStk - lappend result +test assemble-19.6 {unset - nonlocal var} { + -body { + assemble {unset true ::foo::bar} + } + -returnCodes error + -result {variable "::foo::bar" is not local} +} - } +test assemble-19.7 {unset} { + -body { + proc x {} { + set a {} + assemble {unset false a} + info exists a } - x 1 + x } - -result {0 1 1 0 1 0 0 b 1 {b c}} + -result 0 + -cleanup {rename x {}} } -test assemble-2.1 {concat} { +test assemble-19.8 {unset} { -body { - assemble { - push a - push b - push c - concat 3 + proc x {} { + assemble {unset false a} + info exists a + } + x + } + -result 0 + -cleanup {rename x {}} +} +test assemble-19.9 {unset} { + -body { + proc x {} { + assemble {unset true a} + info exists a } + x } - -result abc + -returnCodes error + -result {can't unset "a": no such variable} + -cleanup {rename x {}} } -test assemble-3.1 {expr} { +test assemble-19.10 {unsetArray} { -body { - assemble { - push {1+2+3+4+5} - exprStk + proc x {} { + set a(b) {} + assemble {push b; unsetArray false a} + info exists a(b) } + x } - -result 15 + -result 0 + -cleanup {rename x {}} } -test assemble-4.1 {eval} { + +test assemble-19.11 {unsetArray} { -body { - assemble { - push {join [list [expr {1+2+3+4+5}] a] {}} - evalStk + proc x {} { + assemble {push b; unsetArray false a} + info exists a(b) } + x } - -result 15a + -result 0 + -cleanup {rename x {}} } -test assemble-4.2 {eval} { +test assemble-19.12 {unsetArray} { -body { proc x {} { - assemble { - push 3 - store n - pop - eval {expr {3*$n + 1}} - push 1 - add - } + assemble {push b; unsetArray true a} + info exists a(b) } x } - -result 11 + -returnCodes error + -result {can't unset "a(b)": no such variable} + -cleanup {rename x {}} } -test assemble-4.3 {expr} { +test assemble-20.1 {unbalanced stack} { -body { - proc x {} { + list \ + [catch { + assemble { + push 3 + dup + mult + push 4 + dup + mult + pop + expon + } + } result] $result $::errorInfo + } + -result {1 {stack underflow} {stack underflow + in assembly code between lines 1 and end of assembly code*}} + -match glob + -returnCodes ok +} + +test assemble-20.2 {unbalanced stack} {*}{ + -body { + list \ + [catch { + assemble { + label a + push {} + label b + pop + label c + pop + label d + push {} + } + } result] $result $::errorInfo + } + -result {1 {stack underflow} {stack underflow + in assembly code between lines 7 and 8*}} + -match glob + -returnCodes ok +} + +test assemble-21.1 {Inconsistent stack usage} {*}{ + -body { + proc x {y} { assemble { - push 3 - store n - pop - expr {3*$n + 1} + load y + jumpFalse else + push 0 + jump then + label else push 1 - add + push 2 + label then + pop } } - x + catch {x 1} + set errorInfo } - -result 11 + -match glob + -result {inconsistent stack depths on two execution paths + ("assemble" body, line 10)*} } - -test assemble-30.1 {Ulam's 3n+1 problem, TAL implementation} { + +test assemble-22.1 {Ulam's 3n+1 problem, TAL implementation} { -body { proc ulam {n} { assemble { -- cgit v0.12