path: root/tclasm.tcl

#!/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]
    } 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} {
    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
}