diff options
| -rw-r--r-- | ChangeLog | 15 | ||||
| -rw-r--r-- | generic/tclAssembly.c | 83 | ||||
| -rw-r--r-- | tests/assemble.test | 1129 |
3 files changed, 1128 insertions, 99 deletions
@@ -1,9 +1,20 @@ +2010-09-26 Kevin B. Kenny <kennykb@acm.org> + + * tests/assemble.test: Added many new tests moving toward a more + comprehensive test suite for the assembler. + * generic/tclAssembly.c: Fixed bugs exposed by the new tests: + (a) [bitnot] and [not] had incorrect operand counts. (b) + INST_CONCAT cannot concatenate zero objects. (c) misspelt error + messages. (d) the "assembly code" internal representation lacked + a duplicator, which caused double-frees of the Bytecode object + if assembly code ever was duplicated. + 2010-09-25 Kevin B. Kenny <kennykb@acm.org> [dogeen-assembler-branch] - * tclAssembly.c: Massive refactoring of the assembler - * tclAssembly.h: to use a Tcl-like syntax (and use + * generic/tclAssembly.c: Massive refactoring of the assembler + * generic/tclAssembly.h: to use a Tcl-like syntax (and use * tests/assemble.test: Tcl_ParseCommand to parse it). The * tests/assemble1.bench: refactoring also ensures that Tcl_Tokens in the assembler have string ranges inside the source diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 689e9f9..c83f5d6 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -35,8 +35,6 @@ typedef struct AssembleEnv { /* Static functions defined in this file */ static void AddBasicBlockRangeToErrorInfo(AssembleEnv*, BasicBlock*); -static void AddInstructionToErrorInfo(Tcl_Interp* interp, Tcl_Obj* bcList, - int index); static BasicBlock * AllocBB(AssembleEnv*); static int AssembleOneLine(AssembleEnv* envPtr); static void BBAdjustStackDepth(BasicBlock* bbPtr, int consumed, int produced); @@ -54,6 +52,7 @@ static int CheckSignedOneByte(Tcl_Interp*, int); static int CheckStack(AssembleEnv*); 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); static int FindLocalVar(AssembleEnv* envPtr, Tcl_Token** tokenPtrPtr); static int FinishAssembly(AssembleEnv*); static void FreeAssembleCodeInternalRep(Tcl_Obj *objPtr); @@ -74,7 +73,7 @@ static void SyncStackDepth(AssembleEnv*); static const Tcl_ObjType assembleCodeType = { "assemblecode", FreeAssembleCodeInternalRep, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ + DupAssembleCodeInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL /* setFromAnyProc */ }; @@ -123,11 +122,16 @@ talInstDesc talInstructionTable[] = { {"appendStk", ASSEM_1BYTE, INST_APPEND_STK, 2, 1}, + {"bitand", ASSEM_1BYTE , INST_BITAND , 2 , 1}, + {"bitnot", ASSEM_1BYTE, INST_BITNOT, 1, 1}, + {"bitor", ASSEM_1BYTE , INST_BITOR , 2 , 1}, + {"bitxor", ASSEM_1BYTE , INST_BITXOR , 2 , 1}, {"concat", ASSEM_CONCAT1, INST_CONCAT1, INT_MIN,1}, + {"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}, {"evalStk", ASSEM_1BYTE, INST_EVAL_STK, 1, 1}, - {"expr", ASSEM_EVAL, INST_EXPR_STK, 0, 1}, - {"exprStk", ASSEM_1BYTE, INST_EXPR_STK, 1, 1}, {"exist", ASSEM_LVT4, INST_EXIST_SCALAR, 0, 1}, {"existArray", @@ -138,14 +142,9 @@ talInstDesc talInstructionTable[] = { 2, 1}, {"existStk", ASSEM_1BYTE, INST_EXIST_STK, 1, 1}, - {"bitand", ASSEM_1BYTE , INST_BITAND , 2 , 1}, - {"bitnot", ASSEM_1BYTE, INST_BITNOT, 2, 1}, - {"bitor", ASSEM_1BYTE , INST_BITOR , 2 , 1}, - {"bitxor", ASSEM_1BYTE , INST_BITXOR , 2 , 1}, - {"div", ASSEM_1BYTE, INST_DIV, 2, 1}, - {"dup", ASSEM_1BYTE , INST_DUP , 1 , 2}, - {"eq", ASSEM_1BYTE , INST_EQ , 2 , 1}, {"expon", ASSEM_1BYTE, INST_EXPON, 2, 1}, + {"expr", ASSEM_EVAL, INST_EXPR_STK, 0, 1}, + {"exprStk", ASSEM_1BYTE, INST_EXPR_STK, 1, 1}, {"ge", ASSEM_1BYTE , INST_GE , 2 , 1}, {"gt", ASSEM_1BYTE , INST_GT , 2 , 1}, {"incr", ASSEM_LVT1, INST_INCR_SCALAR1, @@ -225,7 +224,7 @@ talInstDesc talInstructionTable[] = { {"mod", ASSEM_1BYTE, INST_MOD, 2, 1}, {"mult", ASSEM_1BYTE , INST_MULT , 2 , 1}, {"neq", ASSEM_1BYTE , INST_NEQ , 2 , 1}, - {"not", ASSEM_1BYTE, INST_LNOT, 2, 1}, + {"not", ASSEM_1BYTE, INST_LNOT, 1, 1}, {"over", ASSEM_OVER, INST_OVER, INT_MIN, -1-1}, {"pop", ASSEM_1BYTE , INST_POP , 1 , 0}, {"reverse", ASSEM_REVERSE, INST_REVERSE, INT_MIN, -1-0}, @@ -1023,11 +1022,16 @@ AssembleOneLine(AssembleEnv* assemEnvPtr) Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); goto cleanup; } - if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK - || Tcl_GetIntFromObj(interp, operand1Obj, &opnd) != TCL_OK) { + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckOneByte(interp, opnd) != TCL_OK) { goto cleanup; } - if (CheckOneByte(interp, opnd)) { + 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); + } goto cleanup; } BBEmitInstInt1(assemEnvPtr, tblind, opnd, opnd); @@ -1466,7 +1470,8 @@ FindLocalVar(AssembleEnv* assemEnvPtr, if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot use this instruction" - " in non-proc context", -1)); + " to create a variable" + " in a non-proc context", -1)); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL); } return -1; @@ -1475,7 +1480,6 @@ FindLocalVar(AssembleEnv* assemEnvPtr, return localVar; } - /* *----------------------------------------------------------------------------- * @@ -1544,7 +1548,7 @@ CheckNamespaceQualifiers(Tcl_Interp* interp, Tcl_AppendToObj(result, name, -1); Tcl_AppendToObj(result, "\" is not local", -1); Tcl_SetObjResult(interp, result); - Tcl_SetErrorCode(interp, "TCL", "ASSEMBLE", "NONLOCAL", name, + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONLOCAL", name, NULL); return TCL_ERROR; } @@ -1577,7 +1581,7 @@ CheckOneByte(Tcl_Interp* interp, { Tcl_Obj* result; /* Error message */ if (value < 0 || value > 0xff) { - 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", "ASSEMBLE", "1BYTE", NULL); return TCL_ERROR; @@ -2082,7 +2086,42 @@ AddBasicBlockRangeToErrorInfo(AssembleEnv* assemEnvPtr, } /* - *---------------------------------------------------------------------- + *----------------------------------------------------------------------------- + * + * DupAssembleCodeInternalRep -- + * + * Part of the Tcl object type implementation for Tcl assembly language + * bytecode. We do not copy the bytecode intrep. Instead, we return + * without setting copyPtr->typePtr, so the copy is a plain string copy + * of the assembly source, and if it is to be used as a compiled + * expression, it will need to be reprocessed. + * + * This makes sense, because with Tcl's copy-on-write practices, the + * usual (only?) time Tcl_DuplicateObj() will be called is when the copy + * is about to be modified, which would invalidate any copied bytecode + * anyway. The only reason it might make sense to copy the bytecode is if + * we had some modifying routines that operated directly on the intrep, + * as we do for lists and dicts. + * + * Results: + * None. + * + * Side effects: + * None. + * + *----------------------------------------------------------------------------- + */ + +static void +DupAssembleCodeInternalRep( + Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr) +{ + return; +} + +/* + *----------------------------------------------------------------------------- * * FreeAssembleCodeInternalRep -- * @@ -2096,7 +2135,7 @@ AddBasicBlockRangeToErrorInfo(AssembleEnv* assemEnvPtr, * Side effects: * May free allocated memory. Leaves objPtr untyped. * - *---------------------------------------------------------------------- + *----------------------------------------------------------------------------- */ static void diff --git a/tests/assemble.test b/tests/assemble.test index d64f004..3263002 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -4,11 +4,27 @@ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.2 namespace import -force ::tcltest::* } -set assemble tcl::unsupported::assemble +namespace eval tcl::unsupported {namespace export assemble} +namespace import tcl::unsupported::assemble + +# Procedure to make code that fills the literal and local variable tables, +# to force instructions to spill to four bytes. + +proc fillTables {} { + set s {} + set sep {} + for {set i 0} {$i < 256} {incr i} { + append s $sep [list set v$i literal$i] + set sep \n + } + return $s +} + +# assemble-1 - TclNRAssembleObjCmd test assemble-1.1 {wrong # args, direct eval} { -body { - eval [list ::tcl::unsupported::assemble] + eval [list assemble] } -returnCodes error -result {wrong # args*} @@ -17,7 +33,7 @@ test assemble-1.1 {wrong # args, direct eval} { test assemble-1.2 {wrong # args, direct eval} { -body { - eval [list ::tcl::unsupported::assemble too many] + eval [list assemble too many] } -returnCodes error -result {wrong # args*} @@ -27,7 +43,7 @@ test assemble-1.2 {wrong # args, direct eval} { test assemble-1.3 {error reporting, direct eval} { -body { list [catch { - eval [list ::tcl::unsupported::assemble { + eval [list assemble { # bad opcode rubbish }] @@ -37,22 +53,24 @@ test assemble-1.3 {error reporting, direct eval} { -result {1 {bad instruction "rubbish":*} {bad instruction "rubbish":* while executing "rubbish" - ("::tcl::unsupported::assemble" body, line 3)*}} + ("assemble" body, line 3)*}} -cleanup {unset result} } test assemble-1.4 {simple direct eval} { -body { - eval [list ::tcl::unsupported::assemble {push {this is a test}}] + eval [list assemble {push {this is a test}}] } -result {this is a test} } +# assemble-2 - CompileAssembleObj + test assemble-2.1 {bytecode reuse, direct eval} { -body { set x {push "this is a test"} - list [eval [list ::tcl::unsupported::assemble $x]] \ - [eval [list ::tcl::unsupported::assemble $x]] + list [eval [list assemble $x]] \ + [eval [list assemble $x]] } -result {{this is a test} {this is a test}} } @@ -62,12 +80,12 @@ test assemble-2.2 {bytecode discard, direct eval} { set x {load value} proc p1 {x} { set value value1 - tcl::unsupported::assemble $x + assemble $x } proc p2 {x} { set a b set value value2 - tcl::unsupported::assemble $x + assemble $x } list [p1 $x] [p2 $x] } @@ -82,16 +100,18 @@ test assemble-2.2 {bytecode discard, direct eval} { test assemble-2.3 {null script, direct eval} { -body { set x {} - tcl::unsupported::assemble $x + assemble $x } -result {} -cleanup {unset x} } +# assemble-3 - TclCompileAssembleCmd + test assemble-3.1 {wrong # args, compiled path} { -body { proc x {} { - tcl::unsupported::assemble + assemble } x } @@ -103,61 +123,1019 @@ test assemble-3.1 {wrong # args, compiled path} { test assemble-3.2 {wrong # args, compiled path} { -body { proc x {} { - tcl::unsupported::assemble too many + assemble too many } x } -returnCodes error -match glob -result {wrong # args:*} + -cleanup { + rename x {} + } } -if 0 { +# assemble-4 - TclAssembleCode mainline -test assemble-1.3 {empty body} { - -body { $assemble "" } - -result {} +test assemble-4.1 {syntax error} { + -body { + proc x {} { + assemble { + {}extra + } + } + list [catch x result] $result $::errorInfo + } + -cleanup { + rename x {} + unset result + } + -match glob + -result {1 {extra characters after close-brace} {extra characters after close-brace + while executing +"{}extra + " + ("assemble" body, line 2)*}} } -test assemble-1.4 {empty body} { +test assemble-4.2 {null command} { + -body { + proc x {} { + assemble { + push hello; pop;;push goodbye + } + } + x + } + -result goodbye + -cleanup { + rename x {} + } +} + +# assemble-5 - GetNextOperand off-nominal cases + +test assemble-5.1 {unsupported expansion} { + -body { + proc x {y} { + assemble { + {*}$y + } + } + list [catch {x {push hello}} result] $result $::errorCode + } + -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} + -cleanup { + rename x {} + unset result + } +} + +test assemble-5.2 {unsupported substitution} { + -body { + proc x {y} { + assemble { + $y + } + } + list [catch {x {nop}} result] $result $::errorCode + } + -cleanup { + rename x {} + unset result + } + -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} +} + +test assemble-5.3 {unsupported substitution} { + -body { + proc x {} { + assemble { + [x] + } + } + list [catch {x} result] $result $::errorCode + } + -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} +} + +test assemble-5.4 {backslash substitution} { + -body { + proc x {} { + assemble { + p\x75sh\ + hello\ world + } + } + x + } + -cleanup { + rename x {} + } + -result {hello world} +} + +# assemble-6 - ASSEM_PUSH + +test assemble-6.1 {push, wrong # args} { + -body { + assemble push + } + -returnCodes error + -match glob + -result {wrong # args*} +} + +test assemble-6.2 {push, wrong # args} { + -body { + assemble {push too many} + } + -returnCodes error + -match glob + -result {wrong # args*} +} + + +test assemble-6.3 {push} { + -body { + eval [list assemble {push hello}] + } + -result hello +} + +test assemble-6.4 {push4} { + -body { + proc x {} " + [fillTables] + assemble {push hello} + " + x + } + -cleanup { + rename x {} + } + -result hello +} + +# assemble-7 - ASSEM_1BYTE + +test assemble-7.1 {add, wrong # args} { + -body { + assemble {add excess} + } + -returnCodes error + -match glob + -result {wrong # args*} +} + +test assemble-7.2 {add} { -body { - proc x y { - tcl::unsupported::assemble "" + assemble { + push 2 + push 2 + add + } + } + -result {4} +} + +test assemble-7.3 {appendArrayStk} { + -body { + set a(b) {hello, } + assemble { + push a + push b + push world + appendArrayStk } - x 1} - -result {} + set a(b) + } + -result {hello, world} + -cleanup {unset a} } -test assemble-1.4.1 {unknown assembly instruction} { +test assemble-7.4 {appendStk} { -body { - list [catch { - tcl::unsupported::assemble { - push 2 - push 2 - rubbish + set a {hello, } + assemble { + push a + push world + appendStk + } + set a + } + -result {hello, world} + -cleanup {unset a} +} + +test assemble-7.5 {bitwise ops} { + -body { + list \ + [assemble {push 0b1100; push 0b1010; bitand}] \ + [assemble {push 0b1100; bitnot}] \ + [assemble {push 0b1100; push 0b1010; bitor}] \ + [assemble {push 0b1100; push 0b1010; bitxor}] + } + -result {8 -13 14 6} +} + +test assemble-7.6 {div} { + -body { + assemble {push 999999; push 7; div} + } + -result 142857 +} + +test assemble-7.7 {dup} { + -body { + assemble { + push 1; dup; dup; add; dup; add; dup; add; add + } + } + -result 9 +} + +test assemble-7.8 {eq} { + -body { + list \ + [assemble {push able; push baker; eq}] \ + [assemble {push able; push able; eq}] + } + -result {0 1} +} + + +test assemble-7.9 {evalStk} { + -body { + assemble { + push {concat test 7.3} + evalStk + } + } + -result {test 7.3} +} + +test assemble-7.9a {evalStk, syntax} { + -body { + assemble { + push {{}bad} + evalStk + } + } + -returnCodes error + -result {extra characters after close-brace} +} + +test assemble-7.9b {evalStk, backtrace} { + -body { + proc y {z} { + error testing + } + proc x {} { + assemble { + push { + # test error in evalStk + y asd + } + evalStk } - } result] $result $errorCode $errorInfo + } + list [catch x result] $result $errorInfo } + -result {1 testing {testing + while executing +"error testing" + (procedure "y" line 2) + invoked from within +"y asd"*}} -match glob - -result {1 {bad instruction "rubbish":*} {bad instruction "rubbish":* + -cleanup { + rename y {} + rename x {} + } +} + +test assemble-7.10 {existArrayStk} { + -body { + proc x {name key} { + set a(b) c + assemble { + load name; load key; existArrayStk + } + } + list [x a a] [x a b] [x b a] [x b b] + } + -result {0 1 0 0} + -cleanup {rename x {}} +} + +test assemble-7.11 {existStk} { + -body { + proc x {name} { + set a b + assemble { + load name; existStk + } + } + list [x a] [x b] + } + -result {1 0} + -cleanup {rename x {}} +} + +test assemble-7.12 {expon} { + -body { + assemble {push 3; push 4; expon} + } + -result 81 +} + +test assemble-7.13 {exprStk} { + -body { + assemble { + push {acos(-1)} + exprStk + } + } + -result 3.141592653589793 +} + +test assemble-7.13a {exprStk, syntax} { + -body { + assemble { + push {2+} + exprStk + } + } + -returnCodes error + -result {missing operand at _@_ +in expression "2+_@_"} +} + +test assemble-7.13b {exprStk, backtrace} { + -body { + proc y {z} { + error testing + } + proc x {} { + assemble { + push {[y asd]} + exprStk + } + } + list [catch x result] $result $errorInfo + } + -result {1 testing {testing while executing -"rubbish" - ("tcl::unsupported::assemble" body, line 4)*}} +"error testing" + (procedure "y" line 2) + invoked from within +"y asd"*}} + -match glob + -cleanup { + rename y {} + rename x {} + } +} + +test assemble-7.14 {ge gt le lt} { + -body { + proc x {a b} { + list [assemble {load a; load b; ge}] \ + [assemble {load a; load b; gt}] \ + [assemble {load a; load b; le}] \ + [assemble {load a; load b; lt}] + } + list [x 0 0] [x 0 1] [x 1 0] + } + -result {{1 0 1 0} {0 0 1 1} {1 1 0 0}} + -cleanup {rename x {}} +} + +test assemble-7.15 {incrArrayStk} { + -body { + proc x {} { + set a(b) 5 + assemble { + push a; push b; push 7; incrArrayStk + } + } + x + } + -result 12 + -cleanup {rename x {}} +} + +test assemble-7.16 {incrStk} { + -body { + proc x {} { + set a 5 + assemble { + push a; push 7; incrStk + } + } + x + } + -result 12 + -cleanup {rename x {}} +} + +test assemble-7.17 {land/lor} { + -body { + proc x {a b} { + list \ + [assemble {load a; load b; land}] \ + [assemble {load a; load b; lor}] + } + list [x 0 0] [x 0 23] [x 35 0] [x 47 59] + } + -result {{0 0} {0 1} {0 1} {1 1}} + -cleanup {rename x {}} +} + +test assemble-7.18 {lappendArrayStk} { + -body { + proc x {} { + set able(baker) charlie + assemble { + push able + push baker + push dog + lappendArrayStk + } + } + x + } + -result {charlie dog} + -cleanup {rename x {}} } -test assemble-1.5 {Testing push and add} { - -body { tcl::unsupported::assemble { - push 2 - push 2 - add +test assemble-7.19 {lappendStk} { + -body { + proc x {} { + set able baker + assemble { + push able + push charlie + lappendStk + } + } + x + } + -result {baker charlie} + -cleanup {rename x {}} +} + +test assemble-7.20 {listIndex} { + -body { + assemble { + push {a b c d} + push 2 + listIndex + } + } + -result c +} + +test assemble-7.21 {listLength} { + -body { + assemble { + push {a b c d} + listLength + } + } + -result 4 +} + +test assemble-7.22 {loadArrayStk} { + -body { + proc x {} { + set able(baker) charlie + assemble { + push able + push baker + loadArrayStk + } + } + x + } + -result charlie + -cleanup {rename x {}} +} + +test assemble-7.23 {loadStk} { + -body { + proc x {} { + set able baker + assemble { + push able + loadStk + } + } + x + } + -result baker + -cleanup {rename x {}} +} + +test assemble-7.24 {lsetList} { + -body { + proc x {} { + set l {{a b} {c d} {e f} {g h}} + assemble { + push {2 1}; push i; load l; lsetList + } + } + x + } + -result {{a b} {c d} {e i} {g h}} +} + +test assemble-7.25 {lshift} { + -body { + assemble {push 16; push 4; lshift} } + -result 256 +} + +test assemble-7.26 {mod} { + -body { + assemble {push 123456; push 1000; mod} } - -result {4} + -result 456 +} + +test assemble-7.27 {mult} { + -body { + assemble {push 12345679; push 9; mult} + } + -result 111111111 +} + +test assemble-7.28 {neq} { + -body { + list \ + [assemble {push able; push baker; neq}] \ + [assemble {push able; push able; neq}] + } + -result {1 0} +} + +test assemble-7.29 {not} { + -body { + list \ + [assemble {push 17; not}] \ + [assemble {push 0; not}] + } + -result {0 1} +} + +test assemble-7.30 {pop} { + -body { + assemble {push this; pop; push that} + } + -result that +} + +test assemble-7.31 {rshift} { + -body { + assemble {push 257; push 4; rshift} + } + -result 16 +} + +test assemble-7.32 {storeArrayStk} { + -body { + proc x {} { + assemble { + push able; push baker; push charlie; storeArrayStk + } + array get able + } + x + } + -result {baker charlie} + -cleanup {rename x {}} +} + +test assemble-7.33 {storeStk} { + -body { + proc x {} { + assemble { + push able; push baker; storeStk + } + set able + } + x + } + -result {baker} + -cleanup {rename x {}} +} + +test assemble-7,34 {strcmp} { + -body { + proc x {a b} { + assemble { + load a; load b; strcmp + } + } + list [x able baker] [x baker able] [x baker baker] + } + -result {-1 1 0} + -cleanup {rename x {}} +} + +test assemble-7.35 {streq/strneq} { + -body { + proc x {a b} { + list \ + [assemble {load a; load b; streq}] \ + [assemble {load a; load b; strneq}] + } + list [x able able] [x able baker] + } + -result {{1 0} {0 1}} + -cleanup {rename x {}} +} + +test assemble-7.36 {strindex} { + -body { + assemble {push testing; push 4; strindex} + } + -result i +} + +test assemble-7.37 {strlen} { + -body { + assemble {push testing; strlen} + } + -result 7 +} + +test assemble-7.38 {sub} { + -body { + assemble {push 42; push 17; sub} + } + -result 25 +} + +test assemble-7.39 {uminus} { + -body { + assemble { + push 42; uminus + } + } + -result -42 +} + +test assemble-7.40 {uplus} { + -body { + assemble { + push 42; 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} { + -body { + assemble load + } + -returnCodes error + -match glob + -result {wrong # args*} +} + +test assemble-8.2 {load, wrong # args} { + -body { + assemble {load too many} + } + -returnCodes error + -match glob + -result {wrong # args*} +} + +test assemble-8.3 {nonlocal var} { + -body { + list [catch {assemble {load ::env}} result] $result $errorCode + } + -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}} + -cleanup {unset result} +} + +test assemble-8.4 {bad context} { + -body { + set x 1 + list [catch {assemble {load x}} result] $result $errorCode + } + -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}} + -cleanup {unset result} +} + +test assemble-8.5 {bad context} { + -body { + namespace eval assem { + set x 1 + list [catch {assemble {load x}} result] $result $errorCode + } + } + -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}} + -cleanup {namespace delete assem} +} + +test assemble-8.6 {load1} { + -body { + proc x {a} { + assemble { + load a + } + } + x able + } + -result able + -cleanup {rename x {}} +} + +test assemble-8.7 {load4} { + -body { + proc x {a} " + [fillTables] + set b \$a + assemble {load b} + " + x able + } + -result able + -cleanup {rename x {}} +} + +test assemble-8.8 {loadArray1} { + -body { + proc x {} { + set able(baker) charlie + assemble { + push baker + loadArray able + } + } + x + } + -result charlie + -cleanup {rename x {}} +} + +test assemble-8.9 {loadArray4} { + -body " + proc x {} { + [fillTables] + set able(baker) charlie + assemble { + push baker + loadArray able + } + } + x + " + -result charlie + -cleanup {rename x {}} +} + +test assemble-8.10 {append1} { + -body { + proc x {} { + set y {hello, } + assemble { + push world; append y + } + } + x + } + -result {hello, world} + -cleanup {rename x {}} +} + +test assemble-8.11 {append4} { + -body { + proc x {} " + [fillTables] + set y {hello, } + assemble { + push world; append y + } + " + x + } + -result {hello, world} + -cleanup {rename x {}} +} + +test assemble-8.12 {appendArray1} { + -body { + proc x {} { + set y(z) {hello, } + assemble { + push z; push world; appendArray y + } + } + x + } + -result {hello, world} + -cleanup {rename x {}} +} + +test assemble-8.13 {appendArray4} { + -body { + proc x {} " + [fillTables] + set y(z) {hello, } + assemble { + push z; push world; appendArray y + } + " + x + } + -result {hello, world} + -cleanup {rename x {}} +} + +test assemble-8.14 {lappend1} { + -body { + proc x {} { + set y {hello,} + assemble { + push world; lappend y + } + } + x + } + -result {hello, world} + -cleanup {rename x {}} +} + +test assemble-8.15 {lappend4} { + -body { + proc x {} " + [fillTables] + set y {hello,} + assemble { + push world; lappend y + } + " + x + } + -result {hello, world} + -cleanup {rename x {}} +} + +test assemble-8.16 {lappendArray1} { + -body { + proc x {} { + set y(z) {hello,} + assemble { + push z; push world; lappendArray y + } + } + x + } + -result {hello, world} + -cleanup {rename x {}} +} + +test assemble-8.17 {lappendArray4} { + -body { + proc x {} " + [fillTables] + set y(z) {hello,} + assemble { + push z; push world; lappendArray y + } + " + x + } + -result {hello, world} + -cleanup {rename x {}} +} + +test assemble-8.18 {store1} { + -body { + proc x {} { + assemble { + push test; store y + } + set y + } + x + } + -result {test} + -cleanup {rename x {}} +} + +test assemble-8.19 {store4} { + -body { + proc x {} " + [fillTables] + assemble { + push test; store y + } + set y + " + x + } + -result test + -cleanup {rename x {}} +} + +test assemble-8.20 {storeArray1} { + -body { + proc x {} { + assemble { + push z; push test; storeArray y + } + set y(z) + } + x + } + -result test + -cleanup {rename x {}} +} + +test assemble-8.21 {storeArray4} { + -body { + proc x {} " + [fillTables] + assemble { + push z; push test; storeArray y + } + " + x + } + -result test + -cleanup {rename x {}} +} + +# assemble-9 - ASSEM_CONCAT1, GetIntegerOperand, CheckOneByte + +test assemble-9.1 {wrong # args} { + -body {assemble concat} + -result {wrong # args*} + -match glob + -returnCodes error +} + +test assemble-9.2 {wrong # args} { + -body {assemble {concat too many}} + -result {wrong # args*} + -match glob + -returnCodes error +} + +test assemble-9.3 {not a number} { + -body {assemble {concat rubbish}} + -result {expected integer but got "rubbish"} + -returnCodes error +} +test assemble-9.4 {too small} { + -body {assemble {concat -1}} + -result {operand does not fit in one byte} + -returnCodes error +} +test assemble-9.5 {too small} { + -body {assemble {concat 256}} + -result {operand does not fit in one byte} + -returnCodes error +} +test assemble-9.6 {concat} { + -body { + assemble {push h; push e; push l; push l; push o; concat 5} + } + -result hello +} +test assemble-9.7 {concat} { + -body { + list [catch {assemble {concat 0}} result] $result $::errorCode + } + -result {1 {cannot concatenate zero objects} {TCL ASSEM EMPTYCONCAT}} + -cleanup {unset result} } test assemble-1.6 {Testing push, dup, add} { -body { - tcl::unsupported::assemble { + assemble { push 2 dup add @@ -169,7 +1147,7 @@ test assemble-1.6 {Testing push, dup, add} { test assemble-1.6a {wrong # args} { -body { catch { - tcl::unsupported::assemble { + assemble { push 2 2 dup add @@ -181,13 +1159,13 @@ test assemble-1.6a {wrong # args} { -result {wrong # args: should be "push value" while executing "push 2 2" - ("tcl::unsupported::assemble" body, line 2)* + ("assemble" body, line 2)* } } test assemble-1.7 {longer sequence} { -body { - tcl::unsupported::assemble { + assemble { push 3 dup mult @@ -204,7 +1182,7 @@ test assemble-1.8 {unbalanced stack} { -body { list \ [catch { - tcl::unsupported::assemble { + assemble { push 3 dup mult @@ -226,7 +1204,7 @@ test assemble-1.8a {unbalanced stack} {*}{ -body { list \ [catch { - tcl::unsupported::assemble { + assemble { label a push {} label b @@ -249,7 +1227,7 @@ test assemble-1.8a {unbalanced stack} {*}{ test assemble-1.9 { Testing load within a proc } { -body { proc x y { - tcl::unsupported::assemble { + assemble { load y dup mult @@ -263,7 +1241,7 @@ test assemble-1.9 { Testing load within a proc } { test assemble-1.10 {store and load again} { -body { proc x arg { - tcl::unsupported::assemble { + assemble { push aString store arg pop @@ -280,7 +1258,7 @@ test assemble-1.11 {Testing storeArray and loadArray} { set anArray(1,2) "not_aString" proc x arg { upvar $arg anArray - tcl::unsupported::assemble { + assemble { push 1,2 push aString storeArray anArray @@ -298,7 +1276,7 @@ test assemble-1.11 {Testing storeArray and loadArray} { test assemble-1.12 {Testing loadStk with a variable} { -body { set vara 10 - tcl::unsupported::assemble { + assemble { push vara loadStk dup @@ -316,7 +1294,7 @@ test assemble-1.12 {Testing loadStk with a variable} { test assemble-1.13 {Testing loadStk with an array variable} { -body { set vararr(1,2) 10 - tcl::unsupported::assemble { + assemble { push vararr(1,2) loadStk dup @@ -334,7 +1312,7 @@ test assemble-1.13 {Testing loadStk with an array variable} { test assemble-1.14 {Testing loadStk and storeStk} { -body { set aVar 5 - tcl::unsupported::assemble { + assemble { push aVar push aString storeStk @@ -350,7 +1328,7 @@ test assemble-1.14 {Testing loadStk and storeStk} { test assemble-1.15 {Testing loadArrayStk and storeArrayStk} { -body { set aVar(1,2) 5 - tcl::unsupported::assemble { + assemble { push aVar push 1,2 push aString @@ -371,7 +1349,7 @@ test assemble-1.16 { Testing incr } { -body { proc x arg { set i 5 - tcl::unsupported::assemble { + assemble { push 5 incr i } @@ -385,7 +1363,7 @@ test assemble-1.17 { Testing incrImm } { -body { proc x arg { set i 5 - tcl::unsupported::assemble { + assemble { incrImm i 5 } } @@ -398,7 +1376,7 @@ test assemble-1.18 { Testing incrStk } { -body { proc x arg { set i 5 - tcl::unsupported::assemble { + assemble { push i push 5 incrStk @@ -413,7 +1391,7 @@ test assemble-1.19 { Testing incrStkImm } { -body { proc x arg { set i 5 - tcl::unsupported::assemble { + assemble { push i incrStkImm 5 } @@ -427,7 +1405,7 @@ test assemble-1.20 { Testing incrStkImm } { -body { proc x arg { set i 5 - tcl::unsupported::assemble { + assemble { push i incrStkImm 5 } @@ -441,7 +1419,7 @@ test assemble-1.21 { Testing incrArray } { -body { proc x arg { set i(1,2) 5 - tcl::unsupported::assemble { + assemble { push 1,2 push 5 incrArray i @@ -456,7 +1434,7 @@ test assemble-1.22 { Testing incrArrayImm } { -body { proc x arg { set i(1,2) 5 - tcl::unsupported::assemble { + assemble { push 1,2 incrArrayImm i 5 } @@ -470,7 +1448,7 @@ test assemble-1.23 { Testing incrArrayStk } { -body { proc x arg { set i(1,2) 5 - tcl::unsupported::assemble { + assemble { push i push 1,2 push 5 @@ -486,7 +1464,7 @@ test assemble-1.24 { Testing incrArrayStkImm } { -body { proc x arg { set i(1,2) 5 - tcl::unsupported::assemble { + assemble { push i push 1,2 incrArrayStkImm 5 @@ -505,7 +1483,7 @@ test assemble-1.24 { Testing incrArrayStkImm } { test assemble-1.25 { Testing label and jumpTrue } { -body { proc x {arg1 arg2} { - tcl::unsupported::assemble { + assemble { label a load arg2 push 2 @@ -530,7 +1508,7 @@ test assemble-1.25 { Testing label and jumpTrue } { test assemble-1.26 { Testing label and jumpFalse } { -body { proc x {arg1 arg2} { - tcl::unsupported::assemble { + assemble { label a load arg2 push 2 @@ -555,7 +1533,7 @@ test assemble-1.26 { Testing label and jumpFalse } { test assemble-1.27 {forward jumps} { -body { proc x {arg1 arg2 arg3} { - tcl::unsupported::assemble { + assemble { jump a push aString store arg1 @@ -580,7 +1558,7 @@ test assemble-1.27 {forward jumps} { test assemble-1.28 {forward jumps} { -body { proc x {arg1 arg2 arg3} { - tcl::unsupported::assemble { + assemble { jump a push aString store arg1 @@ -605,7 +1583,7 @@ test assemble-1.28 {forward jumps} { test assemble-1.29 {forward jumps} { -body { proc x {arg1 arg2 arg3} { - tcl::unsupported::assemble { + assemble { jump a push aString store arg1 @@ -630,7 +1608,7 @@ test assemble-1.29 {forward jumps} { test assemble-1.30 {Inconsistent stack usage} {*}{ -body { proc x {y} { - tcl::unsupported::assemble { + assemble { load y jumpFalse else push 0 @@ -647,13 +1625,13 @@ test assemble-1.30 {Inconsistent stack usage} {*}{ } -match glob -result {inconsistent stack depths on two execution paths - ("tcl::unsupported::assemble" body, line 9)*} + ("assemble" body, line 9)*} } test assemble-1.31 {unset, exists, lappend - smoke test} { -body { proc x {y} { - tcl::unsupported::assemble { + assemble { exist result store result pop @@ -718,7 +1696,7 @@ test assemble-1.31 {unset, exists, lappend - smoke test} { test assemble-2.1 {concat} { -body { - ::tcl::unsupported::assemble { + assemble { push a push b push c @@ -730,7 +1708,7 @@ test assemble-2.1 {concat} { test assemble-3.1 {expr} { -body { - ::tcl::unsupported::assemble { + assemble { push {1+2+3+4+5} exprStk } @@ -739,7 +1717,7 @@ test assemble-3.1 {expr} { } test assemble-4.1 {eval} { -body { - ::tcl::unsupported::assemble { + assemble { push {join [list [expr {1+2+3+4+5}] a] {}} evalStk } @@ -749,7 +1727,7 @@ test assemble-4.1 {eval} { test assemble-4.2 {eval} { -body { proc x {} { - ::tcl::unsupported::assemble { + assemble { push 3 store n pop @@ -766,7 +1744,7 @@ test assemble-4.2 {eval} { test assemble-4.3 {expr} { -body { proc x {} { - ::tcl::unsupported::assemble { + assemble { push 3 store n pop @@ -783,7 +1761,7 @@ test assemble-4.3 {expr} { test assemble-30.1 {Ulam's 3n+1 problem, TAL implementation} { -body { proc ulam {n} { - tcl::unsupported::assemble { + assemble { load n; # max dup; # max n jump start; # max n @@ -832,7 +1810,8 @@ test assemble-30.1 {Ulam's 3n+1 problem, TAL implementation} { -result {1 2 16 4 16 16 52 8 52 16 52 16 40 52 160 16 52 52 88 20 64 52 160 24 88 40 9232 52 88} } -} +rename fillTables {} +rename assemble {} ::tcltest::cleanupTests return |