path: root/tests/assemble.test

# 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, direct eval} {
    -body {
	eval [list ::tcl::unsupported::assemble]
    }
    -returnCodes error
    -result {wrong # args*}
    -match glob
}

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

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

test assemble-1.4 {simple direct eval} {
    -body {
	eval [list ::tcl::unsupported::assemble {push {this is a test}}]
    }
    -result {this is a test}
}

test assemble-2.1 {bytecode reuse, direct eval} {
    -body {
	set x {push "this is a test"}
	list [eval [list ::tcl::unsupported::assemble $x]] \
	    [eval [list ::tcl::unsupported::assemble $x]]
    }
    -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
	    tcl::unsupported::assemble $x
	}
	proc p2 {x} {
	    set a b
	    set value value2
	    tcl::unsupported::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 {}
	tcl::unsupported::assemble $x
    }
    -result {}
    -cleanup {unset x}
}

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

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

if 0 {

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.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
    } 
    }
    -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"
    while executing
"push 2 2"
    ("tcl::unsupported::assemble" body, line 2)*
    }
}

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 {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
    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
		    push {}
		    label b
		    pop
		    label c
		    pop
		    label d
		    push {}
		}
	    } result] $result $::errorInfo
    }
    -result {1 {stack underflow} {stack underflow
    in assembly code between lines 6 and 8*}}
    -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 {store and load again} {
    -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 {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
	    }
	}
	x 1 2 3
    }
    -result {1}
}

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
	    }
	}
	x 1 2 3
    }
    -result {2}
}

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
	    }
	}
	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
    ("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

	    }
	}
	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
}
test assemble-4.2 {eval} {
    -body {
	proc x {} {
	    ::tcl::unsupported::assemble {
		push 3
		store n
		pop
		eval {expr {3*$n + 1}}
		push 1
		add
	    }
	}
	x
    }
    -result 11
}

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 {
	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 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}
}

}

::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End: