initial commit of Ozgur Dogan Ugurlu's (SF user:dogeen) assembler for the Tcl bytecode language

2 files changed, 576 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
diff --git a/tests/assemble1.bench b/tests/assemble1.bench
new file mode 100644
index 0000000..4f4dbce
--- /dev/null
+++ b/tests/assemble1.bench
@@ -0,0 +1,60 @@
+proc ulam1 {n} {
+    set max $n
+    while {$n != 1} {
+	if {$n > $max} {
+	    set max $n
+	}
+	if {$n % 2} {
+	    set n [expr {3 * $n + 1}]
+	} else {
+	    set n [expr {$n / 2}]
+	}
+    }
+    return $max
+}
+set i 0
+puts [time {ulam1 [incr i]} 10000]
+
+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 ulam2 n [list tcl::unsupported::assemble $code]
+set i 0
+puts [time {ulam2 [incr i]} 10000]