rename tclasm.tcl to tclasm_old.tcl (prepare for redesign of the stack machine)

1 files changed, 352 insertions, 0 deletions

diff --git a/tclasm_old.tcl b/tclasm_old.tcl
new file mode 100755
index 0000000..99b01a1
--- /dev/null
+++ b/tclasm_old.tcl
@@ -0,0 +1,352 @@
+#!/bin/grep this[ ]script
+# this script is to be sourced, not executed by itself
+
+# procedures starting with "__" are internal and not to be used in asm code;
+# procedures starting with "_" are generalized procedures, that are not meant
+# to be directly used for code translated from webasm;
+# the rest are typical procedures webasm code will be mapped to
+
+proc __parse_binary {binary} {
+    set value 0
+
+    for {set bits_remaining $binary} \
+	{"$bits_remaining" != ""} \
+	{set bits_remaining [string range $bits_remaining 1 end]} {
+	    set value [expr $value * 2]
+
+	    if [string match 1* $bits_remaining] {
+		incr value
+	    } elseif [string match 0* $bits_remaining] {
+		# nothing
+	    } else {
+		error "'$binary' cannot be parsed as a binary number"
+	    }
+	}
+
+    return $value
+}
+
+proc __parse_number {number} {
+    if [string match h?* $number] {
+	set value 0x[string range $number 1 end]
+    } elseif [string match b?* $number] {
+	set value [__parse_binary [string range $number 1 end]]
+    } elseif [string match {d[0123456789]?*} $number] {
+	set value [string range $number 1 end]
+    } elseif [string match {-[0123456789]*} $number] {
+	set value $number
+    } elseif [string match {[0123456789]*} $number] {
+	set value $number
+    } else {
+	error "'$number' is not a properly formatted number"
+    }
+
+    return $value
+}
+
+proc __to_binary {number length {can_be_negative -neg_ok}} {
+    if [string equal $can_be_negative -neg_ok] {
+	set can_be_negative 1
+    } elseif [string equal $can_be_negative -no_neg] {
+	set can_be_negative 0
+    } else {
+	error "'$can_be_negative' is not a valid value for the\
+               'can_be_negative' argument"
+    }
+
+    set value [__parse_number $number]
+
+    if {$value < 0 && !$can_be_negative} {
+	error "value '$number' provided where negative values are not allowed"
+    }
+
+    if {($can_be_negative && $value >= 2 ** ($length - 1)) ||
+	$value >= 2 ** $length ||
+	$value < -(2 ** ($length - 1))} {
+	error "value '$number' doesn't fit into $length\
+	       bits[expr $can_be_negative ? "{ with sign}" : "{}"]"
+    }
+
+    for {set result ""} {$length > 0} {incr length -1} {
+	set result [expr $value % 2]$result
+	set value [expr $value >> 1]
+    }
+
+    return $result
+}
+
+# example: __encode_immediate im+=213
+#          __encode_immediate im<<=hAB
+#          __encode_immediate im=im
+#          __encode_immediate im=-33    # negative value only allowed for im=
+#          __encode_immediate im<<=b1101101
+proc __encode_immediate {im_modification} {
+    if [string equal $im_modification im=im] {
+	return 000000000000
+    } elseif [string match im<<=?* $im_modification] {
+	return 1[__to_binary [string range $im_modification 5 end] 11 -no_neg]
+    } elseif [string match im=?* $im_modification] {
+	return 01[__to_binary [string range $im_modification 3 end] 10]
+    } elseif [string match im+=?* $im_modification] {
+	return 001[__to_binary [string range $im_modification 4 end] 9 -no_neg]
+    } else {
+	error "'$im_modification' is not a valid im modification"
+    }
+}
+
+# example: __encode_access_type load
+#          __encode_access_type store
+proc __encode_access_type {type} {
+    if {"$type" == "load"} {
+	return 1
+    } elseif {"$type" == "store"} {
+	return 0
+    } else {
+	error "'$type' is not a valid memory access type"
+    }
+}
+
+# example: __encode_addressing @im
+#          __encode_addressing @im+sp
+proc __encode_addressing {address} {
+    if {"$address" == "@im"} {
+	return 1
+    } elseif {"$address" == "@im+sp"} {
+	return 0
+    } else {
+	error "'$address' is not a valid addressing"
+    }
+}
+
+# example: __encode_reg r0
+#          __encode_reg r1
+proc __encode_reg {register} {
+    if {"$register" == "r0"} {
+	return 1
+    } elseif {"$register" == "r1"} {
+	return 0
+    } else {
+	error "'$register' is not a valid register"
+    }
+v}
+
+# example: __encode_memory_access load r0 @im im=d1840
+#          __encode_memory_access store r1 @im+sp im<<=b1100011
+proc __encode_memory_access {type register address {im_modification im=im}} {
+    set type [__encode_access_type $type]
+    set address [__encode_addressing $address]
+    set register [__encode_reg $register]
+    set im_modification [__encode_immediate $im_modification]
+    return 1$type$address$register$im_modification    
+}
+
+# example: __encode_swap swap
+#          __encode_swap no_swap
+proc __encode_swap {swap_regs} {
+    if {"$swap_regs" == "swap"} {
+	return 1
+    } elseif {"$swap_regs" == "no_swap"} {
+	return 0
+    } else {
+	error "got '$swap_regs' where 'swap' or 'no_swap' was expected"
+    }
+}
+
+# example: __encode_swap swap
+#          __encode_swap no_swap
+proc __encode_cond {cond} {
+    if {"$cond" == "cond"} {
+	return 1
+    } elseif {"$cond" == "non-cond"} {
+	return 0
+    } else {
+	error "got '$cond' where 'cond' or 'non-cond' was expected"
+    }
+}
+
+# example: __encode_extended_instruction halt
+#          __encode_extended_instruction nop
+proc __encode_extended_instruction {instruction} {
+    if {"$instruction" == "nop"} {
+	return [__to_binary 0 9]
+    } elseif {"$instruction" == "halt"} {
+	return [__to_binary 1 9]
+    } elseif {"$instruction" == "set_sp"} {
+	return [__to_binary 2 9]
+    } elseif {"$instruction" == "add"} {
+	return [__to_binary 3 9]
+    } elseif {"$instruction" == "sub"} {
+	return [__to_binary 4 9]
+    } elseif {"$instruction" == "div"} {
+	return [__to_binary 5 9]
+    } elseif {"$instruction" == "mul"} {
+	return [__to_binary 6 9]
+    } elseif {"$instruction" == "tee"} {
+	return [__to_binary 7 9]
+    } else {
+	error "no such extended instruction: '$instruction'"
+    }
+}
+
+# example: _load r0 @im im+=2   # negative values are *not* allowed for im+=
+#          _load r1 @im im=im
+#          _load r0 @im+sp      # im=im is the default if not specified
+#          _load r0 @im im<<=12 # 12 is the value shifted, shift is always by 11
+#          _load r1 @im im=-9   # negative values are only allowed for im=
+#          _load r0 @im+sp im=0 # this results in using only sp for addressing
+proc _load {register address {im_modification im=im}} {
+    puts [__encode_memory_access load $register $address $im_modification]
+}
+
+# example: _store r0 @im im+=2   # same semantics as _load
+#          _store r1 @im im=im
+#          _store r0 @im+sp
+#          _store r0 @im im<<=12
+#          _store r1 @im im=-9
+#          _store r0 @im+sp im=0
+proc _store {register address {im_modification im=im}} {
+    puts [__encode_memory_access store $register $address $im_modification]
+}
+
+# example: _jump im<<=b1101011 cond swap
+#          _jump im=im non-cond
+proc _jump {{im_modification im=im} {cond non-cond} {swap_regs no_swap}} {
+    set swap_regs [__encode_swap $swap_regs]
+    set cond [__encode_cond $cond]
+    puts 01$cond$swap_regs[__encode_immediate $im_modification]
+}
+
+# example: _cond_jump im=h16A swap
+proc _cond_jump {{im_modification im=im} {swap_regs no_swap}} {
+    _jump $im_modification cond $swap_regs
+}
+
+# example: _extended_instruction nop swap  # it's really no longer a true nop...
+#          _extended_instruction halt
+proc _extended_instruction {instruction {swap_regs no_swap}} {
+    set swap_regs [__encode_swap $swap_regs]
+    set no_im_modification 000
+    set instruction [__encode_extended_instruction $instruction]
+    puts 000$swap_regs$no_im_modification$instruction
+}
+
+# example: _immediate im+=4 swap
+#          _immediate im<<=hFF
+#          _immediate im=im      # this one gives the same bit result as 'nop'
+proc _immediate {im_modification {swap_regs no_swap}} {
+    set swap_regs [__encode_swap $swap_regs]
+    set im_modification [__encode_immediate $im_modification]
+    puts 000$swap_regs$im_modification
+}
+
+# example: _exchange_im im<<=b10101010101 swap
+proc _exchange_im {{im_modification im=im} {swap_regs no_swap}} {
+    set swap_regs [__encode_swap $swap_regs]
+    set im_modification [__encode_immediate $im_modification]
+    puts 001$swap_regs$im_modification
+}
+
+proc _const {command number} {
+
+    set value [expr [__parse_number $number] + 0]
+    if {$value < 2 ** 9 && $value >= -(2 ** 9)} {
+	$command im=$value
+    } elseif {$value < 2 ** 20 && $value >= -(2 ** 20)} {
+	_immediate im=[expr $value >> 11]
+	$command im<<=[expr $value & 0x7ff]
+    } elseif {$value < 2 ** 32 && $value >= -(2 ** 31)} {
+	# remove sign
+	set value [expr $value & (2 ** 32 - 1)]
+
+	_immediate im<<=[expr $value >> 22]
+	_immediate im<<=[expr ($value >> 11) & 0x7ff]
+	$command im<<=[expr $value & 0x7ff]
+    } else {
+	error "number '$number' doesn't fit in 32 bits"
+    }
+}
+
+# example: stack up
+#          stack down
+proc stack {direction} {
+    if {"$direction" == "up"} {
+	_load r0 @im+sp im=4
+    } elseif {"$direction" == "down"} {
+	_store r0 @im+sp im=0
+    } else {
+	error "bad opcode: stack $direction"
+    }
+}
+
+# example: store im<<=00000000000
+proc store {{im_modification im=im}} {
+    _store r1 @im $im_modification
+}
+
+# example: load im=hDD
+proc load {{im_modification im=im}} {
+    _load r1 @im $im_modification
+}
+
+# example: jump        # if no address is given - im is used
+#          jump h4FFFE
+proc jump {{address im_address}} {
+    if {"$address" == "im_address"} {
+	_jump im=im
+    } else {
+	_const _jump $address
+    }
+}
+
+# example: cond_jump 
+#          cond_jump b100100110100111101 # same semantics as 'jump'
+proc cond_jump {{address im_address}} {
+    if {"$address" == "im_address"} {
+	_jump im=im cond
+    } else {
+	_const _cond_jump $address
+    }
+}
+
+foreach instruction {halt nop swap add sub div mul tee} {
+    proc $instruction {} "
+        _extended_instruction $instruction
+    "
+}
+
+proc swap {} {
+    _extended_instruction nop swap
+}
+
+
+# example: exchange_im im+=15
+proc exchange_im {{im_modification im=im}} {
+    _exchange_im $im_modification
+}
+
+# example: const -100249
+#          const hDEADBEEF # automatically translates to multiple instructions
+proc const {number} {
+    _const _exchange_im $number
+}
+
+# example: immediate b11101101010000010100010 # analogous to 'const' above
+proc immediate {number} {
+    _const _immediate $number
+}
+
+# example: set_sp h2FFFE # analogous to 'const' and 'immediate' above
+proc set_sp {number} {
+    immediate $number
+    _extended_instruction set_sp
+}
+
+# example: store@ h57574
+proc store@ {address_number} {
+    _const store $address_number
+}
+
+# example: load@ h20000
+proc load@ {address_number} {
+    _const load $address_number
+}