* tclAssembly.c: Massive refactoring of the assembler

* 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
code, which allows for [eval] and [expr] assembler directives
that simply call TclCompileScript and TclCompileExpr recursively.

4 files changed, 686 insertions, 425 deletions

diff --git a/tests/assemble.test b/tests/assemble.test
index d0cbdaa..a2ce531 100644
--- a/tests/assemble.test
+++ b/tests/assemble.test
@@ -33,69 +33,118 @@ test assemble-1.4 {empty body} {
     -result {}
 }
 
+test assemble-1.4.1 {unknown assembly instruction} {
+    -body {
+	list [catch {
+	    tcl::unsupported::assemble {
+		push 2
+		push 2
+		rubbish
+	    }
+	} result] $result $errorCode $errorInfo
+    }
+    -match glob
+    -result {1 {bad instruction "rubbish":*} {bad instruction "rubbish":*
+    while executing
+"rubbish"
+    ("tcl::unsupported::assemble" body, line 4)*}}
+}
+
 test assemble-1.5 {Testing push and add} {
-    -body { tcl::unsupported::assemble {{push 2} {push 2} {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}} }
+    -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}}
+	    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")*}
+    while executing
+"push 2 2"
+    ("tcl::unsupported::assemble" body, line 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}}
+test assemble-1.7 {longer 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 } {*}{
+test assemble-1.8 {unbalanced stack} {
     -body {
 	list \
 	    [catch {
 		tcl::unsupported::assemble {
-		    {push 3} 
+		    push 3
 		    dup 
 		    mult 
-		    {push 4} 
+		    push 4
 		    dup 
 		    mult 
 		    pop 
-		    expon}
+		    expon
+		}
 	    } result] $result $::errorInfo
     }
     -result {1 {stack underflow} {stack underflow
-    between source instruction at list index 0 ("push 3")
-    and end of assembly code*}}
+    in assembly code between lines 1 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}
+		    label a
+		    push {}
+		    label b
+		    pop
+		    label c
+		    pop
+		    label d
+		    push {}
 		}
 	    } 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")*}}
+    in assembly code between lines 6 and 8*}}
     -match glob
    -returnCodes ok
 }
@@ -103,35 +152,46 @@ test assemble-1.8a {unbalanced stack} {*}{
 # 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 }}
+    -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}} 
+test assemble-1.10 {store and load again} {
+    -body {  
+	proc x arg { 
+	    tcl::unsupported::assemble {
+		push aString
+		store arg
+		pop
+		load arg
 	    } 
-	    x "not_aString"	
-	}
-	-result {aString}
+	    } 
+	x "not_aString"	
     }
+    -result {aString}
+}
 
-test assemble-1.11 { Testing storeArray and loadArray } {
-    -body { set anArray(1,2) "not_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} 
+		push 1,2
+		push aString
+		storeArray anArray
 		pop
-		{push 1,2}
-		{loadArray anArray}
+		push 1,2
+		loadArray anArray
 	    } 
 	}
 	x anArray 
@@ -140,30 +200,51 @@ test assemble-1.11 { Testing storeArray and loadArray } {
     -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}}
+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}}
+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 { 
+test assemble-1.14 {Testing loadStk and storeStk} {
+    -body {
 	set aVar 5
 	tcl::unsupported::assemble {
-	    {push aVar} 
-	    {push aString} 
-	    {storeStk} 
+	    push aVar
+	    push aString
+	    storeStk
 	    pop
-	    {push aVar} 
+	    push aVar
 	    loadStk 
 	}
     }
@@ -171,17 +252,17 @@ test assemble-1.14 { Testing loadStk and storeStk } {
     -result {aString}
 }
 
-test assemble-1.15 { Testing loadArrayStk and storeArrayStk } {
+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}
+	    push aVar
+	    push 1,2
+	    push aString
+	    storeArrayStk
 	    pop
-	    {push aVar} 
-	    {push 1,2} 
+	    push aVar
+	    push 1,2
 	    loadArrayStk 
 	}
     }
@@ -192,81 +273,130 @@ test assemble-1.15 { Testing loadArrayStk and storeArrayStk } {
 # Tests for incr instructions 
 
 test assemble-1.16 { Testing incr } {
-    -body { proc x arg { set i 5 
-	tcl::unsupported::assemble {{push 5} {incr i}}
-    } 
+    -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}}
-    } 
+    -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}}
-    } 
+    -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}}
-    } 
+    -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}}
-    } 
+    -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}}
-    } 
+    -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}}
-    } 
+    -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}}
-    } 
+    -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}}
-    } 
+    -body {
+	proc x arg {
+	    set i(1,2) 5 
+	    tcl::unsupported::assemble {
+		push i
+		push 1,2
+		incrArrayStkImm 5
+	    }
+	} 
 	x 1
     }
     -result {10}
@@ -279,9 +409,24 @@ test assemble-1.24 { Testing incrArrayStkImm } {
 
 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}}} 
+	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}
@@ -289,39 +434,99 @@ test assemble-1.25 { Testing label and jumpTrue  } {
 
 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}}} 
+	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 } {
+test assemble-1.27 {forward jumps} {
     -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} }}
+	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 } {
+test assemble-1.28 {forward jumps} {
     -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} }}
+	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 } {
+test assemble-1.29 {forward jumps} {
     -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} }}
+	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}
@@ -331,14 +536,14 @@ 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}
+		load y
+		jumpFalse else
+		push 0
+		jump then
+	      label else
+		push 1
+		push 2
+	      label then
 		pop
 	    }
 	}
@@ -347,67 +552,67 @@ test assemble-1.30 {Inconsistent stack usage} {*}{
     }
     -match glob
     -result {inconsistent stack depths on two execution paths
-    to source instruction at list index 7 ("label then")*}
+    ("tcl::unsupported::assemble" body, line 9)*}
 }
 
 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}
+		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
 
 	    }
 	}
@@ -419,10 +624,10 @@ test assemble-1.31 {unset, exists, lappend - smoke test} {
 test assemble-2.1 {concat} {
     -body {
 	::tcl::unsupported::assemble {
-	    {push a}
-	    {push b}
-	    {push c}
-	    {concat 3}
+	    push a
+	    push b
+	    push c
+	    concat 3
 	}
     }
     -result abc
@@ -431,8 +636,8 @@ test assemble-2.1 {concat} {
 test assemble-3.1 {expr} {
     -body {
 	::tcl::unsupported::assemble {
-	    {push {1+2+3+4+5}}
-	    {exprStk}
+	    push {1+2+3+4+5}
+	    exprStk
 	}
     }
     -result 15
@@ -440,72 +645,89 @@ test assemble-3.1 {expr} {
 test assemble-4.1 {eval} {
     -body {
 	::tcl::unsupported::assemble {
-	    {push {join [list [expr {1+2+3+4+5}] a] {}}}
-	    {evalStk}
+	    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}
+		push 3
+		store n
 		pop
-		{eval {expr {3*$n + 1}}}
+		eval {expr {3*$n + 1}}
+		push 1
+		add
 	    }
 	}
 	x
     }
-    -result 10
+    -result 11
 }
-set ::tcl_traceCompile 0
 
+test assemble-4.3 {expr} {
+    -body {
+	proc x {} {
+	    ::tcl::unsupported::assemble {
+		push 3
+		store n
+		pop
+		expr {3*$n + 1}
+		push 1
+		add
+	    }
+	}
+	x
+    }
+    -result 11
+}
+		
 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
+	proc ulam {n} {
+	    tcl::unsupported::assemble {
+		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 loop;	# max n
+		over 1;         # max n max
+		over 1;		# max in 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
+		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
+		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 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
+		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]
+		pop;		# max
+	    }
+	}
 	set result {}
 	for {set i 1} {$i < 30} {incr i} {
 	    lappend result [ulam $i]
@@ -513,4 +735,11 @@ test assemble-30.1 {Ulam's 3n+1 problem, TAL implementation} {
 	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
+}
+
+::tcltest::cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
\ No newline at end of file
diff --git a/tests/assemble1.bench b/tests/assemble1.bench
index 4f4dbce..18fd3a9 100644
--- a/tests/assemble1.bench
+++ b/tests/assemble1.bench
@@ -12,49 +12,74 @@ proc ulam1 {n} {
     }
     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
+set tcl_traceCompile 2; ulam1 1; set tcl_traceCompile 0
+
+proc ulam2 {n} {
+    tcl::unsupported::assemble {
+	load n;		# max
+	dup;		# max n
+	jump start;     # max n
+	
+	label loop;	# max n
+	over 1;         # max n max
+	over 1;		# max in 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
+    }
+}
+set tcl_traceCompile 2; ulam2 1; set tcl_traceCompile 0
+
+proc test1 {n} {
+    for {set i 1} {$i <= $n} {incr i} {
+	ulam1 $i  
+    }
+}
+proc test2 {n} {
+    for {set i 1} {$i <= $n} {incr i} {
+	ulam2 $i  
+    }
+}
+
+for {set j 0} {$j < 10} {incr j} {
+    test1 1
+    set before [clock microseconds]
+    test1 30000
+    set after [clock microseconds]
+    puts "compiled: [expr {1e-6 * ($after - $before)}]"
     
-} {} code
-proc ulam2 n [list tcl::unsupported::assemble $code]
-set i 0
-puts [time {ulam2 [incr i]} 10000]
+    test2 1
+    set before [clock microseconds]
+    test2 30000
+    set after [clock microseconds]
+    puts "assembled: [expr {1e-6 * ($after - $before)}]"
+}
+    
\ No newline at end of file
diff --git a/tests/execute.test b/tests/execute.test
index ce21040..4519890 100644
--- a/tests/execute.test
+++ b/tests/execute.test
@@ -14,7 +14,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: execute.test,v 1.35 2010/04/05 19:44:45 ferrieux Exp $
+# RCS: @(#) $Id: execute.test,v 1.35.2.1 2010/09/25 14:51:13 kennykb Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -993,6 +993,27 @@ test execute-10.2 {Bug 2802881} -setup {
     interp delete slave
 } -returnCodes error -match glob -result *
 
+test execute-10.3 {Bug 3072640} -setup {
+    proc generate {n} {
+	for {set i 0} {$i < $n} {incr i} {
+	    yield $i
+	}
+    }
+    proc t {args} { 
+	incr ::foo 
+    }
+    trace add execution ::generate enterstep ::t
+} -body {
+    coroutine coro generate 5
+    trace remove execution ::generate enterstep ::t
+    set ::foo
+} -cleanup {
+    unset ::foo
+    rename generate {}
+    rename t {}
+    rename coro {}
+} -result 4
+
 # cleanup
 if {[info commands testobj] != {}} {
    testobj freeallvars
diff --git a/tests/stringComp.test b/tests/stringComp.test
index 2f187be..35c11d1 100644
--- a/tests/stringComp.test
+++ b/tests/stringComp.test
@@ -15,7 +15,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: stringComp.test,v 1.17 2009/06/24 15:17:41 dgp Exp $
+# RCS: @(#) $Id: stringComp.test,v 1.17.4.1 2010/09/25 14:51:13 kennykb Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -44,180 +44,166 @@ test stringComp-1.3 {error condition - undefined method during compile} {
     foo abc 0
 } a
 
-test stringComp-2.1 {string compare, too few args} {
-    proc foo {} {string compare a}
-    list [catch {foo} msg] $msg
-} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
-test stringComp-2.2 {string compare, bad args} {
-    proc foo {} {string compare a b c}
-    list [catch {foo} msg] $msg
-} {1 {bad option "a": must be -nocase or -length}}
-test stringComp-2.3 {string compare, bad args} {
-    list [catch {string compare -length -nocase str1 str2} msg] $msg
-} {1 {expected integer but got "-nocase"}}
-test stringComp-2.4 {string compare, too many args} {
-    list [catch {string compare -length 10 -nocase str1 str2 str3} msg] $msg
-} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
-test stringComp-2.5 {string compare with length unspecified} {
-    list [catch {string compare -length 10 10} msg] $msg
-} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
-test stringComp-2.6 {string compare} {
-    proc foo {} {string compare abcde abdef}
-    foo
-} -1
-test stringComp-2.7 {string compare, shortest method name} {
-    proc foo {} {string c abcde ABCDE}
-    foo
-} 1
-test stringComp-2.8 {string compare} {
-    proc foo {} {string compare abcde abcde}
-    foo
-} 0
-test stringComp-2.9 {string compare with length} {
-    proc foo {} {string compare -length 2 abcde abxyz}
-    foo
-} 0
-test stringComp-2.10 {string compare with special index} {
-    proc foo {} {string compare -length end-3 abcde abxyz}
-    list [catch {foo} msg] $msg
-} {1 {expected integer but got "end-3"}}
-test stringComp-2.11 {string compare, unicode} {
-    proc foo {} {string compare ab\u7266 ab\u7267}
-    foo
-} -1
-test stringComp-2.12 {string compare, high bit} {
-    # This test will fail if the underlying comparaison
-    # is using signed chars instead of unsigned chars.
-    # (like SunOS's default memcmp thus the compat/memcmp.c)
-    proc foo {} {string compare "\x80" "@"}
-    foo
-    # Nb this tests works also in utf8 space because \x80 is
-    # translated into a 2 or more bytelength but whose first byte has
-    # the high bit set.
-} 1
-test stringComp-2.13 {string compare -nocase} {
-    proc foo {} {string compare -nocase abcde abdef}
-    foo
-} -1
-test stringComp-2.14 {string compare -nocase} {
-    proc foo {} {string c -nocase abcde ABCDE}
-    foo
-} 0
-test stringComp-2.15 {string compare -nocase} {
-    proc foo {} {string compare -nocase abcde abcde}
-    foo
-} 0
-test stringComp-2.16 {string compare -nocase with length} {
-    proc foo {} {string compare -length 2 -nocase abcde Abxyz}
-    foo
-} 0
-test stringComp-2.17 {string compare -nocase with length} {
-    proc foo {} {string compare -nocase -length 3 abcde Abxyz}
-    foo
-} -1
-test stringComp-2.18 {string compare -nocase with length <= 0} {
-    proc foo {} {string compare -nocase -length -1 abcde AbCdEf}
-    foo
-} -1
-test stringComp-2.19 {string compare -nocase with excessive length} {
-    proc foo {} {string compare -nocase -length 50 AbCdEf abcde}
-    foo
-} 1
-test stringComp-2.20 {string compare -len unicode} {
-    # These are strings that are 6 BYTELENGTH long, but the length
-    # shouldn't make a different because there are actually 3 CHARS long
-    proc foo {} {string compare -len 5 \334\334\334 \334\334\374}
-    foo
-} -1
-test stringComp-2.21 {string compare -nocase with special index} {
-    proc foo {} {string compare -nocase -length end-3 Abcde abxyz}
-    list [catch {foo} msg] $msg
-} {1 {expected integer but got "end-3"}}
-test stringComp-2.22 {string compare, null strings} {
-    proc foo {} {string compare "" ""}
-    foo
-} 0
-test stringComp-2.23 {string compare, null strings} {
-    proc foo {} {string compare "" foo}
-    foo
-} -1
-test stringComp-2.24 {string compare, null strings} {
-    proc foo {} {string compare foo ""}
-    foo
-} 1
-test stringComp-2.25 {string compare -nocase, null strings} {
-    proc foo {} {string compare -nocase "" ""}
-    foo
-} 0
-test stringComp-2.26 {string compare -nocase, null strings} {
-    proc foo {} {string compare -nocase "" foo}
-    foo
-} -1
-test stringComp-2.27 {string compare -nocase, null strings} {
-    proc foo {} {string compare -nocase foo ""}
-    foo
-} 1
-test stringComp-2.28 {string compare with length, unequal strings} {
-    proc foo {} {string compare -length 2 abc abde}
-    foo
-} 0
-test stringComp-2.29 {string compare with length, unequal strings} {
-    proc foo {} {string compare -length 2 ab abde}
-    foo
-} 0
-test stringComp-2.30 {string compare with NUL character vs. other ASCII} {
-    # Be careful here, since UTF-8 rep comparison with memcmp() of
-    # these puts chars in the wrong order
-    proc foo {} {string compare \x00 \x01}
-    foo
-} -1
-test stringComp-2.31 {string compare, high bit} {
-    proc foo {} {string compare "a\x80" "a@"}
-    foo
-} 1
-test stringComp-2.32 {string compare, high bit} {
-    proc foo {} {string compare "a\x00" "a\x01"}
-    foo
-} -1
-test stringComp-2.33 {string compare, high bit} {
-    proc foo {} {string compare "\x00\x00" "\x00\x01"}
-    foo
-} -1
+## Test string compare|equal over equal constraints
+## Use result for string compare, and negate it for string equal
+## The body will be tested both in and outside a proc
+set i 0
+foreach {tname tbody tresult tcode} {
+    {too few args} {
+	string compare a
+    } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error}
+    {bad args} {
+	string compare a b c
+    } {bad option "a": must be -nocase or -length} {error}
+    {bad args} {
+	string compare -length -nocase str1 str2
+    } {expected integer but got "-nocase"} {error}
+    {too many args} {
+	string compare -length 10 -nocase str1 str2 str3
+    } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error}
+    {compare with length unspecified} {
+	string compare -length 10 10
+    } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error}
+    {basic operation fail} {
+	string compare abcde abdef
+    } {-1} {}
+    {basic operation success} {
+	string compare abcde abcde
+    } {0} {}
+    {with length} {
+	string compare -length 2 abcde abxyz
+    } {0} {}
+    {with special index} {
+	string compare -length end-3 abcde abxyz
+    } {expected integer but got "end-3"} {error}
+    {unicode} {
+	string compare ab\u7266 ab\u7267
+    } {-1} {}
+    {unicode} {string compare \334 \u00dc} 0 {}
+    {unicode} {string compare \334 \u00fc} -1 {}
+    {unicode} {string compare \334\334\334\374\374 \334\334\334\334\334} 1 {}
+    {high bit} {
+	# This test will fail if the underlying comparaison
+	# is using signed chars instead of unsigned chars.
+	# (like SunOS's default memcmp thus the compat/memcmp.c)
+	string compare "\x80" "@"
+	# Nb this tests works also in utf8 space because \x80 is
+	# translated into a 2 or more bytelength but whose first byte has
+	# the high bit set.
+    } {1} {}
+    {-nocase 1} {string compare -nocase abcde abdef} {-1} {}
+    {-nocase 2} {string compare -nocase abcde Abdef} {-1} {}
+    {-nocase 3} {string compare -nocase abcde ABCDE} {0} {}
+    {-nocase 4} {string compare -nocase abcde abcde} {0} {}
+    {-nocase unicode} {
+	string compare -nocase \334 \u00dc
+    } 0 {}
+    {-nocase unicode} {
+	string compare -nocase \334\334\334\374\u00fc \334\334\334\334\334
+    } 0 {}
+    {-nocase with length} {
+	string compare -length 2 -nocase abcde Abxyz
+    } {0} {}
+    {-nocase with length} {
+	string compare -nocase -length 3 abcde Abxyz
+    } {-1} {}
+    {-nocase with length <= 0} {
+	string compare -nocase -length -1 abcde AbCdEf
+    } {-1} {}
+    {-nocase with excessive length} {
+	string compare -nocase -length 50 AbCdEf abcde
+    } {1} {}
+    {-len unicode} {
+	# These are strings that are 6 BYTELENGTH long, but the length
+	# shouldn't make a different because there are actually 3 CHARS long
+	string compare -len 5 \334\334\334 \334\334\374
+    } -1 {}
+    {-nocase with special index} {
+	string compare -nocase -length end-3 Abcde abxyz
+    } {expected integer but got "end-3"} error
+    {null strings} {
+	string compare "" ""
+    } 0 {}
+    {null strings} {
+	string compare "" foo
+    } -1 {}
+    {null strings} {
+	string compare foo ""
+    } 1 {}
+    {-nocase null strings} {
+	string compare -nocase "" ""
+    } 0 {}
+    {-nocase null strings} {
+	string compare -nocase "" foo
+    } -1 {}
+    {-nocase null strings} {
+	string compare -nocase foo ""
+    } 1 {}
+    {with length, unequal strings} {
+	string compare -length 2 abc abde
+    } 0 {}
+    {with length, unequal strings} {
+	string compare -length 2 ab abde
+    } 0 {}
+    {with NUL character vs. other ASCII} {
+	# Be careful here, since UTF-8 rep comparison with memcmp() of
+	# these puts chars in the wrong order
+	string compare \x00 \x01
+    } -1 {}
+    {high bit} {
+	string compare "a\x80" "a@"
+    } 1 {}
+    {high bit} {
+	string compare "a\x00" "a\x01"
+    } -1 {}
+    {high bit} {
+	string compare "\x00\x00" "\x00\x01"
+    } -1 {}
+    {binary equal} {
+	string compare [binary format a100 0] [binary format a100 0]
+    } 0 {}
+    {binary neq} {
+	string compare [binary format a100a 0 1] [binary format a100a 0 0]
+    } 1 {}
+    {binary neq inequal length} {
+	string compare [binary format a20a 0 1] [binary format a100a 0 0]
+    } 1 {}
+} {
+    if {$tname eq ""} { continue }
+    if {$tcode eq ""} { set tcode ok }
+    test stringComp-2.[incr i] "string compare, $tname" \
+	-body [list eval $tbody] \
+	-returnCodes $tcode -result $tresult
+    test stringComp-2.[incr i] "string compare bc, $tname" \
+	-body "[list proc foo {} $tbody];foo" \
+	-returnCodes $tcode -result $tresult
+    if {"error" ni $tcode} {
+	set tresult [expr {!$tresult}]
+    } else {
+	set tresult [string map {compare equal} $tresult]
+    }
+    set tbody [string map {compare equal} $tbody]
+    test stringComp-2.[incr i] "string equal, $tname" \
+	-body [list eval $tbody] \
+	-returnCodes $tcode -result $tresult
+    test stringComp-2.[incr i] "string equal bc, $tname" \
+	-body "[list proc foo {} $tbody];foo" \
+	-returnCodes $tcode -result $tresult
+}
 
-# only need a few tests on equal, since it uses the same code as
-# string compare, but just modifies the return output
-test stringComp-3.1 {string equal} {
-    proc foo {} {string equal abcde abdef}
-    foo
-} 0
-test stringComp-3.2 {string equal} {
-    proc foo {} {string eq abcde ABCDE}
-    foo
-} 0
-test stringComp-3.3 {string equal} {
-    proc foo {} {string equal abcde abcde}
-    foo
-} 1
-test stringComp-3.4 {string equal -nocase} {
-    proc foo {} {string equal -nocase \334\334\334\334\374\374\374\374 \334\334\334\334\334\334\334\334}
+# need a few extra tests short abbr cmd
+test stringComp-3.1 {string compare, shortest method name} {
+    proc foo {} {string c abcde ABCDE}
     foo
 } 1
-test stringComp-3.5 {string equal -nocase} {
-    proc foo {} {string equal -nocase abcde abdef}
+test stringComp-3.2 {string equal, shortest method name} {
+    proc foo {} {string e abcde ABCDE}
     foo
 } 0
-test stringComp-3.6 {string equal -nocase} {
+test stringComp-3.3 {string equal -nocase} {
     proc foo {} {string eq -nocase abcde ABCDE}
     foo
 } 1
-test stringComp-3.7 {string equal -nocase} {
-    proc foo {} {string equal -nocase abcde abcde}
-    foo
-} 1
-test stringComp-3.8 {string equal with length, unequal strings} {
-    proc foo {} {string equal -length 2 abc abde}
-    foo
-} 1
 
 test stringComp-4.1 {string first, too few args} {
     proc foo {} {string first a}