203 lines
8 KiB
Common Lisp
203 lines
8 KiB
Common Lisp
(in-package :cl-uxn)
|
|
|
|
(defmacro define-instruction (name args &body body)
|
|
`(defun ,name (instance opcode)
|
|
(with-uxn (instance)
|
|
(let* ((mode-short (mode-short-p opcode))
|
|
(mode-return (mode-return-p opcode))
|
|
(mode-keep (mode-keep-p opcode))
|
|
(stack (if mode-return return-stack work-stack))
|
|
(start-pointer (uxn-stack-index stack)))
|
|
(declare (ignorable mode-short))
|
|
(macrolet ((get-value (&optional size)
|
|
(case size
|
|
(byte '(stack-pop stack nil))
|
|
(short '(stack-pop stack t))
|
|
(t '(stack-pop stack mode-short))))
|
|
(put-value (value &optional size)
|
|
(case size
|
|
(byte `(stack-push stack ,value nil))
|
|
(short `(stack-push stack ,value t))
|
|
(t `(stack-push stack ,value mode-short))))
|
|
(memory-get (address chop &optional size)
|
|
(case size
|
|
(byte `(memory-read memory ,address ,chop nil))
|
|
(short `(memory-read memory ,address ,chop t))
|
|
(t `(memory-read memory ,address ,chop mode-short))))
|
|
(memory-put (address value chop &optional size)
|
|
(case size
|
|
(byte `(memory-write memory ,address ,value ,chop nil))
|
|
(short `(memory-write memory ,address ,value ,chop t))
|
|
(t `(memory-write memory ,address ,value ,chop mode-short)))))
|
|
(let* ,(parse-define-instruction-args args)
|
|
(declare (ignorable ,@(symbol-or-first args)))
|
|
(when mode-keep
|
|
(setf (uxn-stack-index stack) start-pointer))
|
|
,@body))))))
|
|
|
|
(define-instruction op-null ())
|
|
(define-instruction op-jci ((c byte))
|
|
(let ((addr (memory-get program-counter #x10000 short)))
|
|
(unless (zerop c)
|
|
(setf-16 program-counter (+ program-counter addr))))
|
|
(setf-16 program-counter (+ program-counter 2)))
|
|
(define-instruction op-jmi ()
|
|
(let ((addr (memory-get program-counter #x10000 short)))
|
|
(setf-16 program-counter (+ program-counter addr 2))))
|
|
(define-instruction op-jsi ()
|
|
(stack-push return-stack (+ program-counter 2) 'short)
|
|
(let ((addr (memory-get program-counter #x10000 short)))
|
|
(setf-16 program-counter (+ program-counter addr 2))))
|
|
(define-instruction op-lit ()
|
|
(put-value (aref memory program-counter) byte)
|
|
(setf-16 program-counter (1+ program-counter))
|
|
(when mode-short
|
|
(put-value (aref memory program-counter) byte)
|
|
(setf-16 program-counter (1+ program-counter))))
|
|
(define-instruction op-inc (a)
|
|
(put-value (1+ a)))
|
|
(define-instruction op-pop (x))
|
|
(define-instruction op-nip (a x)
|
|
(put-value a))
|
|
(define-instruction op-swp (a b)
|
|
(put-value a) (put-value b))
|
|
(define-instruction op-rot (a b c)
|
|
(put-value b) (put-value a) (put-value c))
|
|
(define-instruction op-dup (a)
|
|
(put-value a) (put-value a))
|
|
(define-instruction op-ovr (a b)
|
|
(put-value b) (put-value a) (put-value b))
|
|
(define-instruction op-equ (a b)
|
|
(put-value (if (= b a) 1 0)
|
|
byte))
|
|
(define-instruction op-neq (a b)
|
|
(put-value (if (/= b a) 1 0)
|
|
byte))
|
|
(define-instruction op-gth (a b)
|
|
(put-value (if (> b a) 1 0)
|
|
byte))
|
|
(define-instruction op-lth (a b)
|
|
(put-value (if (< b a) 1 0)
|
|
byte))
|
|
(define-instruction op-jmp (addr)
|
|
(setf-16 program-counter
|
|
(if mode-short
|
|
addr
|
|
(+ program-counter (signify addr)))))
|
|
(define-instruction op-jcn (addr (c byte))
|
|
(unless (zerop c)
|
|
(setf-16 program-counter
|
|
(if mode-short
|
|
addr
|
|
(+ program-counter (signify addr))))))
|
|
(define-instruction op-jsr (addr)
|
|
(stack-push (if mode-return work-stack return-stack) program-counter t)
|
|
(setf-16 program-counter
|
|
(if mode-short
|
|
addr
|
|
(+ program-counter (signify addr)))))
|
|
(define-instruction op-sth (a)
|
|
(stack-push (if mode-return work-stack return-stack) a mode-short))
|
|
(define-instruction op-ldz ((addr byte))
|
|
(put-value (memory-get addr #x100)))
|
|
(define-instruction op-stz ((addr byte) val)
|
|
(memory-put addr val #x100))
|
|
(define-instruction op-ldr ((addr byte))
|
|
(put-value (memory-get (+ program-counter (signify addr)) #x10000)))
|
|
(define-instruction op-str ((addr byte) val)
|
|
(memory-put (+ program-counter (signify addr)) val #x10000))
|
|
(define-instruction op-lda ((addr short))
|
|
(put-value (memory-get addr #x10000)))
|
|
(define-instruction op-sta ((addr short) val)
|
|
(memory-put addr val #x10000))
|
|
(define-instruction op-dei ((addr byte))
|
|
(let ((val (funcall *device-input* addr)))
|
|
(when mode-short
|
|
(setf val
|
|
(ash val 8))
|
|
(setf (ldb (byte 8 0) val)
|
|
(funcall *device-input* (mod (1+ addr) #x100))))
|
|
(put-value val)))
|
|
(define-instruction op-deo ((addr byte) val)
|
|
(cond (mode-short (funcall *device-output*
|
|
addr
|
|
(ldb (byte 8 8) val))
|
|
(funcall *device-output*
|
|
(mod (1+ addr) #x100)
|
|
(ldb (byte 8 0) val)))
|
|
(t (funcall *device-output* addr val))))
|
|
(define-instruction op-add (a b)
|
|
(put-value (+ b a)))
|
|
(define-instruction op-sub (a b)
|
|
(put-value (- b a)))
|
|
(define-instruction op-mul (a b)
|
|
(put-value (* b a)))
|
|
(define-instruction op-div (a b)
|
|
(put-value (if (zerop a) 0 (floor b a))))
|
|
(define-instruction op-and (a b)
|
|
(put-value (logand b a)))
|
|
(define-instruction op-ora (a b)
|
|
(put-value (logior b a)))
|
|
(define-instruction op-eor (a b)
|
|
(put-value (logxor b a)))
|
|
(define-instruction op-sft ((a byte) b)
|
|
(put-value (ash (ash b
|
|
(- (ldb (byte 4 0) a)))
|
|
(ldb (byte 4 4) a))))
|
|
|
|
(defmacro register-op-family (&rest args)
|
|
(list*
|
|
'setf
|
|
(mapcan
|
|
(lambda (i)
|
|
(let ((family (first i))
|
|
(function (second i)))
|
|
`((aref *opcode-dispatch-table* (logior ,family #x00)) #',function
|
|
(aref *opcode-dispatch-table* (logior ,family #x20)) #',function
|
|
(aref *opcode-dispatch-table* (logior ,family #x40)) #',function
|
|
(aref *opcode-dispatch-table* (logior ,family #x60)) #',function
|
|
(aref *opcode-dispatch-table* (logior ,family #x80)) #',function
|
|
(aref *opcode-dispatch-table* (logior ,family #xa0)) #',function
|
|
(aref *opcode-dispatch-table* (logior ,family #xc0)) #',function
|
|
(aref *opcode-dispatch-table* (logior ,family #xe0)) #',function)))
|
|
args)))
|
|
|
|
(register-op-family (+inc+ op-inc)
|
|
(+pop+ op-pop)
|
|
(+nip+ op-nip)
|
|
(+swp+ op-swp)
|
|
(+rot+ op-rot)
|
|
(+dup+ op-dup)
|
|
(+ovr+ op-ovr)
|
|
(+equ+ op-equ)
|
|
(+neq+ op-neq)
|
|
(+gth+ op-gth)
|
|
(+lth+ op-lth)
|
|
(+jmp+ op-jmp)
|
|
(+jcn+ op-jcn)
|
|
(+jsr+ op-jsr)
|
|
(+sth+ op-sth)
|
|
(+ldz+ op-ldz)
|
|
(+stz+ op-stz)
|
|
(+ldr+ op-ldr)
|
|
(+str+ op-str)
|
|
(+lda+ op-lda)
|
|
(+sta+ op-sta)
|
|
(+dei+ op-dei)
|
|
(+deo+ op-deo)
|
|
(+add+ op-add)
|
|
(+sub+ op-sub)
|
|
(+mul+ op-mul)
|
|
(+div+ op-div)
|
|
(+and+ op-and)
|
|
(+ora+ op-ora)
|
|
(+eor+ op-eor)
|
|
(+sft+ op-sft))
|
|
(setf (aref *opcode-dispatch-table* +brk+) #'op-null
|
|
(aref *opcode-dispatch-table* +jci+) #'op-jci
|
|
(aref *opcode-dispatch-table* +jmi+) #'op-jmi
|
|
(aref *opcode-dispatch-table* +jsi+) #'op-jsi
|
|
(aref *opcode-dispatch-table* +lit+) #'op-lit
|
|
(aref *opcode-dispatch-table* #xa0) #'op-lit
|
|
(aref *opcode-dispatch-table* #xc0) #'op-lit
|
|
(aref *opcode-dispatch-table* #xe0) #'op-lit)
|