# Commands covered: assemble

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2.2
    namespace import -force ::tcltest::*
}
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 assemble]
    }
    -returnCodes error
    -result {wrong # args*}
    -match glob
}

test assemble-1.2 {wrong # args, direct eval} {
    -body {
	eval [list assemble too many]
    }
    -returnCodes error
    -result {wrong # args*}
    -match glob
}

test assemble-1.3 {error reporting, direct eval} {
    -body {
	list [catch {
	    eval [list assemble {
		# bad opcode
		rubbish
	    }]
	} result] $result $errorInfo
    }
    -match glob
    -result {1 {bad instruction "rubbish":*} {bad instruction "rubbish":*
    while executing
"rubbish"
    ("assemble" body, line 3)*}}
    -cleanup {unset result}
}

test assemble-1.4 {simple direct eval} {
    -body {
	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 assemble $x]] \
	    [eval [list assemble $x]]
    }
    -result {{this is a test} {this is a test}}
}

test assemble-2.2 {bytecode discard, direct eval} {
    -body {
	set x {load value}
	proc p1 {x} {
	    set value value1
	    assemble $x
	}
	proc p2 {x} {
	    set a b
	    set value value2
	    assemble $x
	}
	list [p1 $x] [p2 $x]
    }
    -result {value1 value2}
    -cleanup {
	unset x
	rename p1 {}
	rename p2 {}
    }
}

test assemble-2.3 {null script, direct eval} {
    -body {
	set x {}
	assemble $x
    }
    -result {}
    -cleanup {unset x}
}

# assemble-3 - TclCompileAssembleCmd

test assemble-3.1 {wrong # args, compiled path} {
    -body {
	proc x {} {
	    assemble
	}
	x
    }
    -returnCodes error
    -match glob
    -result {wrong # args:*}
}

test assemble-3.2 {wrong # args, compiled path} {
    -body {
	proc x {} {
	    assemble too many
	}
	x
    }
    -returnCodes error
    -match glob
    -result {wrong # args:*}
    -cleanup {
	rename x {}
    }
}

# assemble-4 - TclAssembleCode mainline

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-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 { 
	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
	}
	set a(b)
    }
    -result {hello, world}
    -cleanup {unset a}
}

test assemble-7.4 {appendStk} {
    -body {
	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
	    }
	}
	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
    -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
"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-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 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
}

# 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 {operand must be positive} {TCL ASSEM POSITIVE}}
    -cleanup {unset result}
}

# assemble-10 -- eval and expr

test assemble-10.1 {eval - wrong # args} {
    -body {
	assemble {eval}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-10.2 {eval - wrong # args} {
    -body {
	assemble {eval too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-10.3 {eval} {
    -body {
	proc x {} {
	    assemble {
		push 3
		store n
		pop
		eval {expr {3*$n + 1}}
		push 1
		add
	    }
	}
	x
    }
    -result 11
    -cleanup {rename x {}}
}

test assemble-10.4 {expr} {
    -body {
	proc x {} {
	    assemble {
		push 3
		store n
		pop
		expr {3*$n + 1}
		push 1
		add
	    }
	}
	x
    }
    -result 11
    -cleanup {rename x {}}
}

test assemble-10.5 {eval and expr - nonsimple} {
    -body {
	proc x {} {
	    assemble {
		eval "s\x65t n 3"
		pop
		expr "\x33*\$n + 1"
		push 1
		add
	    }
	}
	x
    }
    -result 11
    -cleanup {
	rename x {}
    }
}

test assemble-10.6 {eval - noncompilable} {
    -body {
	list [catch {assemble {eval $x}} result] $result $::errorCode
    }
    -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
}

test assemble-10.7 {expr - noncompilable} {
    -body {
	list [catch {assemble {expr $x}} result] $result $::errorCode
    }
    -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
}

# assemble-11 - ASSEM_LVT4 (exist and existArray)
		
test assemble-11.1 {exist - wrong # args} {
    -body {
	assemble {exist}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-11.2 {exist - wrong # args} {
    -body {
	assemble {exist too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-11.3 {nonlocal var} {
    -body {
	list [catch {assemble {exist ::env}} result] $result $errorCode
    }
    -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}}
    -cleanup {unset result}
}

test assemble-11.4 {exist} {
    -body {
	proc x {} {
	    set y z
	    list [assemble {exist y}] \
		[assemble {exist z}]
	}
	x
    }
    -result {1 0}
    -cleanup {rename x {}}
}

test assemble-11.5 {existArray} {
    -body {
	proc x {} {
	    set a(b) c
	    list [assemble {push b; existArray a}] \
		[assemble {push c; existArray a}] \
		[assemble {push a; existArray b}]
	}
	x
    }
    -result {1 0 0}
    -cleanup {rename x {}}
}

# assemble-12 - ASSEM_LVT1 (incr and incrArray)
		
test assemble-12.1 {incr - wrong # args} {
    -body {
	assemble {incr}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-12.2 {incr - wrong # args} {
    -body {
	assemble {incr too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-12.3 {incr nonlocal var} {
    -body {
	list [catch {assemble {incr ::env}} result] $result $errorCode
    }
    -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}}
    -cleanup {unset result}
}

test assemble-12.4 {incr} {
    -body {
	proc x {} {
	    set y 5
	    assemble {push 3; incr y}
	}
	x
    }
    -result 8
    -cleanup {rename x {}}
}

test assemble-12.5 {incrArray} {
    -body {
	proc x {} {
	    set a(b) 5
	    assemble {push b; push 3; incrArray a}
	}
	x
    }
    -result 8
    -cleanup {rename x {}}
}

test assemble-12.6 {incr, stupid stack restriction} {
    -body {
	proc x {} "
	    [fillTables]
            set y 5
            assemble {push 3; incr y}
        "
	list [catch {x} result] $result $errorCode
    }
    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
    -cleanup {unset result; rename x {}}
}

# assemble-13 -- ASSEM_LVT1_SINT1 - incrImm and incrArrayImm

test assemble-13.1 {incrImm - wrong # args} {
    -body {
	assemble {incrImm x}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-13.2 {incrImm - wrong # args} {
    -body {
	assemble {incrImm too many args}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-13.3 {incrImm nonlocal var} {
    -body {
	list [catch {assemble {incrImm ::env 2}} result] $result $errorCode
    }
    -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}}
    -cleanup {unset result}
}

test assemble-13.4 {incrImm not a number} {
    -body {
	proc x {} {
	    assemble {incrImm x rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}

test assemble-13.5 {incrImm too big} {
    -body {
	proc x {} {
	    assemble {incrImm x 0x80}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
    -cleanup {rename x {}; unset result}
}
    
test assemble-13.6 {incrImm too small} {
    -body {
	proc x {} {
	    assemble {incrImm x -0x81}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
    -cleanup {rename x {}; unset result}
}

test assemble-13.7 {incrImm} {
    -body {
	proc x {} {
	    set y 1
	    list [assemble {incrImm y -0x80}] [assemble {incrImm y 0x7f}]
	}
	x
    }
    -result {-127 0}
    -cleanup {rename x {}}
}

test assemble-13.8 {incrArrayImm} {
    -body {
	proc x {} {
	    set a(b) 5
	    assemble {push b; incrArrayImm a 3}
	}
	x
    }
    -result 8
    -cleanup {rename x {}}
}

test assemble-13.9 {incrImm, stupid stack restriction} {
    -body {
	proc x {} "
	    [fillTables]
            set y 5
            assemble {incrImm y 3}
        "
	list [catch {x} result] $result $errorCode
    }
    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
    -cleanup {unset result; rename x {}}
}

# assemble-14 -- ASSEM_SINT1 (incrArrayStkImm and incrStkImm)

test assemble-14.1 {incrStkImm - wrong # args} {
    -body {
	assemble {incrStkImm}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-14.2 {incrStkImm - wrong # args} {
    -body {
	assemble {incrStkImm too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-14.3 {incrStkImm not a number} {
    -body {
	proc x {} {
	    assemble {incrStkImm rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}

test assemble-14.4 {incrStkImm too big} {
    -body {
	proc x {} {
	    assemble {incrStkImm 0x80}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
    -cleanup {rename x {}; unset result}
}
    
test assemble-14.5 {incrStkImm too small} {
    -body {
	proc x {} {
	    assemble {incrStkImm -0x81}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}}
    -cleanup {rename x {}; unset result}
}

test assemble-14.6 {incrStkImm} {
    -body {
	proc x {} {
	    set y 1
	    list [assemble {push y; incrStkImm -0x80}] \
		[assemble {push y; incrStkImm 0x7f}]
	}
	x
    }
    -result {-127 0}
    -cleanup {rename x {}}
}

test assemble-14.7 {incrArrayStkImm} {
    -body {
	proc x {} {
	    set a(b) 5
	    assemble {push a; push b; incrArrayStkImm 3}
	}
	x
    }
    -result 8
    -cleanup {rename x {}}
}

# assemble-15 - invokeStk

test assemble-15.1 {invokeStk - wrong # args} {
    -body {
	assemble {invokeStk}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-15.2 {invokeStk - wrong # args} {
    -body {
	assemble {invokeStk too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-15.3 {invokeStk - not a number} {
    -body {
	proc x {} {
	    assemble {invokeStk rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}

test assemble-15.4 {invokeStk - no operands} {
    -body {
	proc x {} {
	    assemble {invokeStk 0}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be positive} {TCL ASSEM POSITIVE}}
    -cleanup {rename x {}; unset result}
}

test assemble-15.5 {invokeStk1} {
    -body {
	tcl::unsupported::assemble {push concat; push 1; push 2; invokeStk 3}
    }
    -result {1 2}
}

test assemble-15.6 {invokeStk4} {
    -body {
	proc x {n} {
	    set code {push concat}
	    set shouldbe {}
	    for {set i 1} {$i < $n} {incr i} {
		append code \n {push a} $i
		lappend shouldbe a$i
	    }
	    append code \n {invokeStk} { } $n
	    set is [assemble $code]
	    expr {$is eq $shouldbe}
	}
	list [x 254] [x 255] [x 256] [x 257]
    }
    -result {1 1 1 1}
    -cleanup {rename x {}}
}

# assemble-16 -- jumps and labels

test assemble-16.1 {label, wrong # args} {
    -body {
	assemble {label}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-16.2 {label, wrong # args} {
    -body {
	assemble {label too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-16.3 {label, bad subst} {
    -body {
	list [catch {assemble {label $foo}} result] $result $::errorCode
    }
    -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
    -cleanup {unset result}
}

test assemble-16.4 {duplicate label} {
    -body {
	list [catch {assemble {label foo; label foo}} result] \
	    $result $::errorCode
    }
    -result {1 {duplicate definition of label "foo"} {TCL ASSEM DUPLABEL foo}}
}

test assemble-16.5 {jump, wrong # args} {
    -body {
	assemble {jump}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-16.6 {jump, wrong # args} {
    -body {
	assemble {jump too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-16.7 {jump, bad subst} {
    -body {
	list [catch {assemble {jump $foo}} result] $result $::errorCode
    }
    -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
    -cleanup {unset result}
}

test assemble-16.8 {jump - ahead and back} {
    -body {
	assemble {
	    jump three

	    label one
	    push a
	    jump four

	    label two
	    push b
	    jump six

	    label three
	    push c
	    jump five

	    label four
	    push d
	    jump two

	    label five
	    push e
	    jump one

	    label six
	    push f
	    concat 6
	}
    }
    -result ceadbf
}

test assemble-16.9 {jump - resolve a label multiple times} {
    -body {
	proc x {} {
	    set case 0
	    set result {}
	    assemble {
		jump common
		
		label zero
		pop		
		incrImm case 1
		pop
		push a
		append result
		pop
		jump common
		
		label one
		pop
		incrImm case 1
		pop
		push b
		append result
		pop
		jump common
		
		label common
		load case
		dup
		push 0
		eq
		jumpTrue zero
		dup
		push 1
		eq
		jumpTrue one
		dup
		push 2
		eq
		jumpTrue two
		dup
		push 3
		eq
		jumpTrue three
		
		label two
		pop
		incrImm case 1
		pop
		push c
		append result
		pop
		jump common
		
		label three
		pop
		incrImm case 1
		pop
		push d
		append result
	    }
	}
	x
    }
    -result abcd
    -cleanup {rename x {}}
}

test assemble-16.10 {jump4} {
    -body {
	assemble "push x; jump one; label two; [string repeat {dup; pop;} 128]
	      jump three; label one; jump two; label three"
    }
    -result x
}

test assemble-16.11 {jumpTrue} {
    -body {
	proc x {y} {
	    assemble {
		load y
		jumpTrue then
		push no
		jump else
		label then
		push yes
		label else
	    }
	}
	list [x 0] [x 1]
    }
    -result {no yes}
    -cleanup {rename x {}}
}

test assemble-16.12 {jumpFalse} {
    -body {
	proc x {y} {
	    assemble {
		load y
		jumpFalse then
		push no
		jump else
		label then
		push yes
		label else
	    }
	}
	list [x 0] [x 1]
    }
    -result {yes no}
    -cleanup {rename x {}}
}

test assemble-16.13 {jump to undefined label} {
    -body {
	list [catch {assemble {jump nowhere}} result] $result $::errorCode
    }
    -result {1 {undefined label "nowhere"} {TCL ASSEM NOLABEL nowhere}}
}

test assemble-16.14 {jump to undefined label, line number correct?} {
    -body {
	catch {assemble {#1
	    #2
	    #3
	    jump nowhere
	    #5
	    #6
	}}
	set ::errorInfo
    }
    -match glob
    -result {*"assemble" body, line 4*}
}

# assemble-17 - over

test assemble-17.1 {over - wrong # args} {
    -body {
	assemble {over}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-17.2 {over - wrong # args} {
    -body {
	assemble {over too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-17.3 {over - bad subst} {
    -body {
	assemble {over $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}

test assemble-17.4 {over - not a number} {
    -body {
	proc x {} {
	    assemble {over rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}

test assemble-17.5 {over - negative operand count} {
    -body {
	proc x {} {
	    assemble {over -1}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}}
    -cleanup {rename x {}; unset result}
}

test assemble-17.6 {over} {
    -body {
	proc x {} {
	    assemble {
		push 1
		push 2
		push 3
		over 0
		store x
		pop
		pop
		pop
		pop
		load x
	    }
	}
	x
    }
    -result 3
    -cleanup {rename x {}}
}

test assemble-17.7 {over} {
    -body {
	proc x {} {
	    assemble {
		push 1
		push 2
		push 3
		over 2
		store x
		pop
		pop
		pop
		pop
		load x
	    }
	}
	x
    }
    -result 1
    -cleanup {rename x {}}
}

# assemble-18 - reverse

test assemble-18.1 {reverse - wrong # args} {
    -body {
	assemble {reverse}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-18.2 {reverse - wrong # args} {
    -body {
	assemble {reverse too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-18.3 {reverse - bad subst} {
    -body {
	assemble {reverse $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}

test assemble-18.4 {reverse - not a number} {
    -body {
	proc x {} {
	    assemble {reverse rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected integer but got "rubbish"}
    -cleanup {rename x {}}
}

test assemble-18.5 {reverse - negative operand count} {
    -body {
	proc x {} {
	    assemble {reverse -1}
	}
	list [catch x result] $result $::errorCode
    }
    -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}}
    -cleanup {rename x {}; unset result}
}

test assemble-18.6 {reverse - zero operand count} {
    -body {
	proc x {} {
	    assemble {push 1; reverse 0}
	}
	x
    }
    -result 1
    -cleanup {rename x {}}
}

test assemble-18.7 {reverse} {
    -body {
	proc x {} {
	    assemble {
		push 1
		push 2
		push 3
		reverse 1
		store x
		pop
		pop
		pop
		load x
	    }
	}
	x
    }
    -result 3
    -cleanup {rename x {}}
}

test assemble-18.8 {reverse} {
    -body {
	proc x {} {
	    assemble {
		push 1
		push 2
		push 3
		reverse 3
		store x
		pop
		pop
		pop
		load x
	    }
	}
	x
    }
    -result 1
    -cleanup {rename x {}}
}

# assemble-19 - ASSEM_BOOL (strmatch, unsetStk, unsetArrayStk)

test assemble-19.1 {strmatch - wrong # args} {
    -body {
	assemble {strmatch}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-19.2 {strmatch - wrong # args} {
    -body {
	assemble {strmatch too many}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-19.3 {strmatch - bad subst} {
    -body {
	assemble {strmatch $foo}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}

test assemble-18.4 {strmatch - not a boolean} {
    -body {
	proc x {} {
	    assemble {strmatch rubbish}
	}
	x
    }
    -returnCodes error
    -result {expected boolean value but got "rubbish"}
    -cleanup {rename x {}}
}

test assemble-18.5 {strmatch} {
    -body {
	proc x {a b} {
	    list [assemble {load a; load b; strmatch 0}] \
		[assemble {load a; load b; strmatch 1}]
	}
	list [x foo*.grill fengbar.grill] [x foo*.grill foobar.grill] [x foo*.grill FOOBAR.GRILL]
    }
    -result {{0 0} {1 1} {0 1}}
    -cleanup {rename x {}}
}

test assemble-18.6 {unsetStk} {
    -body {
	proc x {} {
	    set a {}
	    assemble {push a; unsetStk false}
	    info exists a
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}

test assemble-18.7 {unsetStk} {
    -body {
	proc x {} {
	    assemble {push a; unsetStk false}
	    info exists a
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}
test assemble-18.8 {unsetStk} {
    -body {
	proc x {} {
	    assemble {push a; unsetStk true}
	    info exists a
	}
	x
    }
    -returnCodes error
    -result {can't unset "a": no such variable}
    -cleanup {rename x {}}
}

test assemble-18.9 {unsetArrayStk} {
    -body {
	proc x {} {
	    set a(b) {}
	    assemble {push a; push b; unsetArrayStk false}
	    info exists a(b)
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}

test assemble-18.10 {unsetArrayStk} {
    -body {
	proc x {} {
	    assemble {push a; push b; unsetArrayStk false}
	    info exists a(b)
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}
test assemble-18.11 {unsetArrayStk} {
    -body {
	proc x {} {
	    assemble {push a; push b; unsetArrayStk true}
	    info exists a(b)
	}
	x
    }
    -returnCodes error
    -result {can't unset "a(b)": no such variable}
    -cleanup {rename x {}}
}

# assemble-19 -- ASSEM_BOOL_LVT4 (unset; unsetArray)

test assemble-19.1 {unset - wrong # args} {
    -body {
	assemble {unset one}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-19.2 {unset - wrong # args} {
    -body {
	assemble {unset too many args}
    }
    -returnCodes error
    -match glob
    -result {wrong # args*}
}

test assemble-19.3 {unset - bad subst -arg 1} {
    -body {
	assemble {unset $foo bar}
    }
    -returnCodes error
    -match glob
    -result {assembly code may not contain substitutions}
}

test assemble-19.4 {unset - not a boolean} {
    -body {
	proc x {} {
	    assemble {unset rubbish trash}
	}
	x
    }
    -returnCodes error
    -result {expected boolean value but got "rubbish"}
    -cleanup {rename x {}}
}

test assemble-19.5 {unset - bad subst - arg 2} {
    -body {
	assemble {unset true $bar}
    }
    -returnCodes error
    -result {assembly code may not contain substitutions}
}

test assemble-19.6 {unset - nonlocal var} {
    -body {
	assemble {unset true ::foo::bar}
    }
    -returnCodes error
    -result {variable "::foo::bar" is not local}
}

test assemble-19.7 {unset} {
    -body {
	proc x {} {
	    set a {}
	    assemble {unset false a}
	    info exists a
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}

test assemble-19.8 {unset} {
    -body {
	proc x {} {
	    assemble {unset false a}
	    info exists a
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}
test assemble-19.9 {unset} {
    -body {
	proc x {} {
	    assemble {unset true a}
	    info exists a
	}
	x
    }
    -returnCodes error
    -result {can't unset "a": no such variable}
    -cleanup {rename x {}}
}

test assemble-19.10 {unsetArray} {
    -body {
	proc x {} {
	    set a(b) {}
	    assemble {push b; unsetArray false a}
	    info exists a(b)
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}

test assemble-19.11 {unsetArray} {
    -body {
	proc x {} {
	    assemble {push b; unsetArray false a}
	    info exists a(b)
	}
	x
    }
    -result 0
    -cleanup {rename x {}}
}
test assemble-19.12 {unsetArray} {
    -body {
	proc x {} {
	    assemble {push b; unsetArray true a}
	    info exists a(b)
	}
	x
    }
    -returnCodes error
    -result {can't unset "a(b)": no such variable}
    -cleanup {rename x {}}
}

test assemble-20.1 {unbalanced stack} {
    -body {
	list \
	    [catch {
		assemble {
		    push 3
		    dup 
		    mult 
		    push 4
		    dup 
		    mult 
		    pop 
		    expon
		}
	    } result] $result $::errorInfo
    }
    -result {1 {stack underflow} {stack underflow
    in assembly code between lines 1 and end of assembly code*}}
    -match glob
   -returnCodes ok
}

test assemble-20.2 {unbalanced stack} {*}{
    -body {
	list \
	    [catch {
		assemble {
		    label a
		    push {}
		    label b
		    pop
		    label c
		    pop
		    label d
		    push {}
		}
	    } result] $result $::errorInfo
    }
    -result {1 {stack underflow} {stack underflow
    in assembly code between lines 7 and 8*}}
    -match glob
   -returnCodes ok
}

test assemble-21.1 {Inconsistent stack usage} {*}{
    -body {
	proc x {y} {
	    assemble {
		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
    ("assemble" body, line 10)*}
}

test assemble-22.1 {Ulam's 3n+1 problem, TAL implementation} {
    -body {
	proc ulam {n} {
	    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 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}
}

rename fillTables {}
rename assemble {}

::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End: