summaryrefslogtreecommitdiffstats
path: root/tests/assemble.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/assemble.test')
-rw-r--r--tests/assemble.test516
1 files changed, 516 insertions, 0 deletions
diff --git a/tests/assemble.test b/tests/assemble.test
new file mode 100644
index 0000000..d0cbdaa
--- /dev/null
+++ b/tests/assemble.test
@@ -0,0 +1,516 @@
+# Commands covered: assemble
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest 2.2
+ namespace import -force ::tcltest::*
+}
+set assemble tcl::unsupported::assemble
+
+test assemble-1.1 {wrong # args} {
+ -body { $assemble 1 2 }
+ -result {wrong # args: should be "tcl::unsupported::assemble bytecodeList"}
+ -returnCodes error
+}
+
+test assemble-1.2 {wrong arg formatting} {
+ -body { $assemble 1 }
+ -match glob
+ -returnCodes error
+ -result {bad instruction "1"*}
+}
+
+test assemble-1.3 {empty body} {
+ -body { $assemble "" }
+ -result {}
+}
+
+test assemble-1.4 {empty body} {
+ -body {
+ proc x y {
+ tcl::unsupported::assemble ""
+ }
+ x 1}
+ -result {}
+}
+
+test assemble-1.5 {Testing push and add} {
+ -body { tcl::unsupported::assemble {{push 2} {push 2} {add}} }
+ -result {4}
+}
+
+test assemble-1.6 {Testing push, dup, add} {
+ -body { tcl::unsupported::assemble {{push 2} {dup} {add}} }
+ -result {4}
+}
+
+test assemble-1.6a {wrong # args} {
+ -body {
+ catch {
+ tcl::unsupported::assemble {{push 2 2} {dup} {add}}
+ }
+ set ::errorInfo
+ }
+ -match glob
+ -result {wrong # args: should be "push value"
+ processing source instruction at list index 0 ("push 2 2")*}
+}
+
+test assemble-1.7 { Testing push, dup, mul, push, dup, mult, push, expon sequence } {
+ -body { tcl::unsupported::assemble {{push 3} dup mult {push 4} dup mult expon}}
+ -result {1853020188851841}
+}
+
+test assemble-1.8 { Testing push, dup, mul, push, dup, mult, push, expon, pop sequence with unbalanced stack } {*}{
+ -body {
+ list \
+ [catch {
+ tcl::unsupported::assemble {
+ {push 3}
+ dup
+ mult
+ {push 4}
+ dup
+ mult
+ pop
+ expon}
+ } result] $result $::errorInfo
+ }
+ -result {1 {stack underflow} {stack underflow
+ between source instruction at list index 0 ("push 3")
+ and end of assembly code*}}
+ -match glob
+ -returnCodes ok
+}
+test assemble-1.8a {unbalanced stack} {*}{
+ -body {
+ list \
+ [catch {
+ tcl::unsupported::assemble {
+ {label a}
+ {pop}
+ {label b}
+ {pop}
+ }
+ } result] $result $::errorInfo
+ }
+ -result {1 {stack underflow} {stack underflow
+ between source instruction at list index 0 ("label a")
+ and source instruction at list index 2 ("label b")*}}
+ -match glob
+ -returnCodes ok
+}
+
+# Tests for load and store
+
+test assemble-1.9 { Testing load within a proc } {
+ -body { proc x y { tcl::unsupported::assemble {{load y} dup mult }}
+ x 10
+ }
+ -result {100}
+}
+
+test assemble-1.10 { Testing store and load, saving the string "aString" to a variable and then
+ loading it from variable } {
+ -body {
+ proc x arg {
+ tcl::unsupported::assemble {
+ {push aString} {store arg} {pop} {load arg}}
+ }
+ x "not_aString"
+ }
+ -result {aString}
+ }
+
+test assemble-1.11 { Testing storeArray and loadArray } {
+ -body { set anArray(1,2) "not_aString"
+ proc x arg {
+ upvar $arg anArray
+ tcl::unsupported::assemble {
+ {push 1,2}
+ {push aString}
+ {storeArray anArray}
+ pop
+ {push 1,2}
+ {loadArray anArray}
+ }
+ }
+ x anArray
+ }
+ -cleanup {unset anArray}
+ -result {aString}
+}
+
+test assemble-1.12 { Testing loadStk with a variable } {
+ -body { set vara 10
+ tcl::unsupported::assemble {{push vara} loadStk dup mult {push 4} dup mult add}}
+ -cleanup {unset vara}
+ -result {116}
+}
+
+test assemble-1.13 { Testing loadStk with an array variable } {
+ -body { set vararr(1,2) 10
+ tcl::unsupported::assemble {{push vararr(1,2)} loadStk dup mult {push 4} dup mult add}}
+ -cleanup {unset vararr}
+ -result {116}
+}
+
+
+test assemble-1.14 { Testing loadStk and storeStk } {
+ -body {
+ set aVar 5
+ tcl::unsupported::assemble {
+ {push aVar}
+ {push aString}
+ {storeStk}
+ pop
+ {push aVar}
+ loadStk
+ }
+ }
+ -cleanup {unset aVar}
+ -result {aString}
+}
+
+test assemble-1.15 { Testing loadArrayStk and storeArrayStk } {
+ -body {
+ set aVar(1,2) 5
+ tcl::unsupported::assemble {
+ {push aVar}
+ {push 1,2}
+ {push aString}
+ {storeArrayStk}
+ pop
+ {push aVar}
+ {push 1,2}
+ loadArrayStk
+ }
+ }
+ -cleanup {unset aVar}
+ -result {aString}
+}
+
+# Tests for incr instructions
+
+test assemble-1.16 { Testing incr } {
+ -body { proc x arg { set i 5
+ tcl::unsupported::assemble {{push 5} {incr i}}
+ }
+ x 1
+ }
+ -result {10}
+}
+
+test assemble-1.17 { Testing incrImm } {
+ -body { proc x arg { set i 5
+ tcl::unsupported::assemble {{incrImm i 5}}
+ }
+ x 1
+ }
+ -result {10}
+}
+
+test assemble-1.18 { Testing incrStk } {
+ -body { proc x arg { set i 5
+ tcl::unsupported::assemble {{push i} {push 5} {incrStk}}
+ }
+ x 1
+ }
+ -result {10}
+}
+
+test assemble-1.19 { Testing incrStkImm } {
+ -body { proc x arg { set i 5
+ tcl::unsupported::assemble {{push i} {incrStkImm 5}}
+ }
+ x 1
+ }
+ -result {10}
+}
+
+test assemble-1.20 { Testing incrStkImm } {
+ -body { proc x arg { set i 5
+ tcl::unsupported::assemble {{push i} {incrStkImm 5}}
+ }
+ x 1
+ }
+ -result {10}
+}
+
+test assemble-1.21 { Testing incrArray } {
+ -body { proc x arg { set i(1,2) 5
+ tcl::unsupported::assemble {{push 1,2} {push 5} {incrArray i}}
+ }
+ x 1
+ }
+ -result {10}
+}
+
+test assemble-1.22 { Testing incrArrayImm } {
+ -body { proc x arg { set i(1,2) 5
+ tcl::unsupported::assemble {{push 1,2} {incrArrayImm i 5}}
+ }
+ x 1
+ }
+ -result {10}
+}
+
+test assemble-1.23 { Testing incrArrayStk } {
+ -body { proc x arg { set i(1,2) 5
+ tcl::unsupported::assemble {{push i} {push 1,2} {push 5} {incrArrayStk}}
+ }
+ x 1
+ }
+ -result {10}
+}
+
+test assemble-1.24 { Testing incrArrayStkImm } {
+ -body { proc x arg { set i(1,2) 5
+ tcl::unsupported::assemble {{push i} {push 1,2} {incrArrayStkImm 5}}
+ }
+ x 1
+ }
+ -result {10}
+}
+
+# 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} { tcl::unsupported::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} { tcl::unsupported::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
+ }
+ -result {32}
+}
+
+test assemble-1.27 { Testing trampoline undefined label and jump } {
+ -body {
+ proc x {arg1 arg2 arg3} { tcl::unsupported::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} }}
+ x 1 2 3
+ }
+ -result {1}
+}
+
+test assemble-1.28 { Testing trampoline undefined label and jump } {
+ -body {
+ proc x {arg1 arg2 arg3} { tcl::unsupported::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} }}
+ x 1 2 3
+ }
+ -result {2}
+}
+
+test assemble-1.29 { Testing trampoline undefined label and jump } {
+ -body {
+ proc x {arg1 arg2 arg3} { tcl::unsupported::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} }}
+ x 1 2 3
+ }
+ -result {3}
+}
+
+test assemble-1.30 {Inconsistent stack usage} {*}{
+ -body {
+ proc x {y} {
+ tcl::unsupported::assemble {
+ {load y}
+ {jumpFalse else}
+ {push 0}
+ {jump then}
+ {label else}
+ {push 1}
+ {push 2}
+ {label then}
+ pop
+ }
+ }
+ catch {x 1}
+ set errorInfo
+ }
+ -match glob
+ -result {inconsistent stack depths on two execution paths
+ to source instruction at list index 7 ("label then")*}
+}
+
+test assemble-1.31 {unset, exists, lappend - smoke test} {
+ -body {
+ proc x {y} {
+ tcl::unsupported::assemble {
+ {exist result}
+ {store result}
+ {pop}
+
+ {exist result}
+ {lappend result}
+ {pop}
+
+ {push result}
+ {push y}
+ {existStk}
+ {lappendStk}
+ {pop}
+
+ {push y}
+ {unsetStk true}
+ {exist y}
+ {lappend result}
+ {pop}
+
+ {push {}}
+ {store foo}
+ {pop}
+ {exist foo}
+ {lappend result}
+ {pop}
+
+ {unset true foo}
+ {exist foo}
+ {lappend result}
+ {pop}
+
+ {push a}
+ {existArray z}
+ {lappend result}
+ {pop}
+
+ {push a}
+ {push b}
+ {lappendArray z}
+ {lappend result}
+ {pop}
+
+ {push z}
+ {push a}
+ {existArrayStk}
+ {lappend result}
+ {pop}
+
+ {push z}
+ {push a}
+ {push c}
+ {lappendArrayStk}
+ {lappend result}
+
+ }
+ }
+ x 1
+ }
+ -result {0 1 1 0 1 0 0 b 1 {b c}}
+}
+
+test assemble-2.1 {concat} {
+ -body {
+ ::tcl::unsupported::assemble {
+ {push a}
+ {push b}
+ {push c}
+ {concat 3}
+ }
+ }
+ -result abc
+}
+
+test assemble-3.1 {expr} {
+ -body {
+ ::tcl::unsupported::assemble {
+ {push {1+2+3+4+5}}
+ {exprStk}
+ }
+ }
+ -result 15
+}
+test assemble-4.1 {eval} {
+ -body {
+ ::tcl::unsupported::assemble {
+ {push {join [list [expr {1+2+3+4+5}] a] {}}}
+ {evalStk}
+ }
+ }
+ -result 15a
+}
+set ::tcl_traceCompile 2
+test assemble-4.2 {eval} {
+ -body {
+ proc x {} {
+ ::tcl::unsupported::assemble {
+ {push 3}
+ {store n}
+ pop
+ {eval {expr {3*$n + 1}}}
+ }
+ }
+ x
+ }
+ -result 10
+}
+set ::tcl_traceCompile 0
+
+test assemble-30.1 {Ulam's 3n+1 problem, TAL implementation} {
+ -body {
+ regsub -all {\#[^\n]*} {
+ {load n} # max
+ {dup} # max n
+ {jump start} # max n
+
+ {label loop} # max n
+ {over 1} # max n max
+ {over 1} # max n max n
+ {ge} # man n max>=n
+ {jumpTrue skip} # max n
+
+ {reverse 2} # n max
+ {pop} # n
+ {dup} # n n
+
+ {label skip} # max n
+ {dup} # max n n
+ {push 2} # max n n 2
+ {mod} # max n n%2
+ {jumpTrue odd} # max n
+
+ {push 2} # max n 2
+ {div} # max n/2 -> max n
+ {jump start} # max n
+
+ {label odd} # max n
+ {push 3} # max n 3
+ {mult} # max 3*n
+ {push 1} # max 3*n 1
+ {add} # max 3*n+1
+
+ {label start} # max n
+ {dup} # max n n
+ {push 1} # max n n 1
+ {neq} # max n n>1
+ {jumpTrue loop} # max n
+
+ {pop} # max
+
+ } {} code
+ proc ulam n [list tcl::unsupported::assemble $code]
+ set result {}
+ for {set i 1} {$i < 30} {incr i} {
+ lappend result [ulam $i]
+ }
+ set result
+ }
+ -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}
+} \ No newline at end of file
generated by cgit v0.12 at 2024-11-25 16:00:55 (GMT)