skittles/cl-uxn
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

First working implementation

Browse source
This commit is contained in:
skittles 2025-01-29 05:21:25 -03:00
parent 11dc0c570d
commit 5bcf47053f
Signed by: skittles
SSH key fingerprint: SHA256:HRivAeH3pqmygtqz/hc6xpO2uV5K3MQQyvYoWXPw4z8
6 changed files with 429 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
cl-uxn.asd Normal file
View file

@ -0,0 +1,12 @@
(defsystem "cl-uxn"
:version "0.0.1"
:author "skittles"
:license "GPL-3.0-or-later"
:depends-on ()
:components ((:module "src" :serial t
:components ((:file "packages")
(:file "opcodes")
(:file "helpers")
(:file "main")
(:file "op-functions"))))
:description "Emulator for the Uxn virtual machine")

21
src/helpers.lisp Normal file
View file

@ -0,0 +1,21 @@
(in-package :cl-uxn)
(deftype uint8 () '(unsigned-byte 8))
(deftype sint8 () '(byte 8))
(deftype uint16 () '(unsigned-byte 16))
(define-condition uxn-condition (condition)
((instance :initarg :instance :reader instance)))
(defun signify (value) (if (> value 127) (- value 256) value))
(defmacro setf-8 (symbol form) `(setf ,symbol (mod ,form #x100)))
(defmacro setf-16 (symbol form) `(setf ,symbol (mod ,form #x10000)))
(defun symbol-or-first (list)
(mapcar (lambda (i) (if (listp i) (first i) i)) list))
(defun parse-define-instruction-args (list)
(mapcar (lambda (i)
(if (listp i)
`(,(first i) (get-value ,(second i)))
`(,i (get-value nil))))
list))

121
src/main.lisp Normal file
View file

@ -0,0 +1,121 @@
(in-package :cl-uxn)
(defvar *breakpoints* ()
"List of addresses which the cl-uxn:run function should invoke the signal uxn-breakpoint.")
(defvar *watchpoints* ())
(defvar *device-input* nil
"Callback function with two arguments: The port written to and the value.")
(defvar *device-output* nil
"Callback function with one argument: The port read from. It must return an integer.")
(define-condition uxn-breakpoint (uxn-condition)
())
(define-condition uxn-watchpoint (uxn-condition)
((address :initarg :address :reader address)
(old-value :initarg :old-value :reader old-value)
(new-value :initarg :new-value :reader new-value)))
(defstruct uxn
(memory (make-array #x10000
:element-type 'uint8
:initial-element 0)
:type (simple-array uint8 (#x10000))
:read-only t)
(work-stack (make-uxn-stack)
:type uxn-stack
:read-only t)
(return-stack (make-uxn-stack)
:type uxn-stack
:read-only t)
(program-counter 0
:type uint16))
(defstruct uxn-stack
(buffer (make-array #x100
:element-type 'uint8
:initial-element 0)
:type (simple-array uint8 (#x100))
:read-only t)
(index #xff
:type uint8))
(defun mode-short-p (opcode) (logbitp 5 opcode))
(defun mode-return-p (opcode) (logbitp 6 opcode))
(defun mode-keep-p (opcode) (logbitp 7 opcode))
(defun stack-pop (stack wide)
(let ((result (aref (uxn-stack-buffer stack) (uxn-stack-index stack))))
(setf-8 (uxn-stack-index stack) (1- (uxn-stack-index stack)))
(when wide
(setf (ldb (byte 8 8) result)
(aref (uxn-stack-buffer stack) (uxn-stack-index stack)))
(setf-8 (uxn-stack-index stack)
(1- (uxn-stack-index stack))))
result))
(defun stack-push (stack value wide)
(let ((result (mod value #x10000)))
(setf-8 (uxn-stack-index stack)
(1+ (uxn-stack-index stack)))
(when wide
(setf (aref (uxn-stack-buffer stack) (uxn-stack-index stack))
(ldb (byte 8 8) result))
(setf-8 (uxn-stack-index stack)
(1+ (uxn-stack-index stack))))
(setf (aref (uxn-stack-buffer stack) (uxn-stack-index stack))
(ldb (byte 8 0) result))))
(defun memory-read (memory address chop wide)
(let ((result (aref memory address)))
(when wide
(setf result (ash result 8))
(setf (ldb (byte 8 0) result) (aref memory (mod (1+ address)
chop))))
result))
(defun memory-write (memory address value chop wide)
(let ((result (mod value #x10000)))
(cond (wide (setf-8 (aref memory address)
(ldb (byte 8 8) result))
(setf-8 (aref memory (mod (1+ address)
chop))
(ldb (byte 8 0) result)))
(t (setf-8 (aref memory address)
(ldb (byte 8 0) result))))))
(defmacro with-uxn ((state) &body body)
`(with-accessors ((memory uxn-memory)
(work-stack uxn-work-stack)
(return-stack uxn-return-stack)
(program-counter uxn-program-counter))
,state
,@body))
(defparameter *opcode-dispatch-table*
(make-array #x100
:element-type 'function
:initial-element (lambda (instance opcode)
(declare (ignore instance opcode))
(error "Unknown opcode"))))
;;; General uxn functions
(defun make-uxn-with-image (initial-memory)
"Creates an instance with a starting memory array."
(assert (<= (length initial-memory) #xff00))
(let ((instance (make-uxn)))
(replace (uxn-memory instance) initial-memory :start1 #x100)
instance))
(defun run (instance &optional vector)
"Run the routine at address vector in the specified instance."
(with-uxn (instance)
(when vector (setf program-counter vector))
(do ((returned nil)) (returned)
(when (member program-counter *breakpoints*)
(signal 'uxn-breakpoint instance))
(setf returned (run-step instance)))))
(defun run-step (instance)
"Execute the instruction at the instance's program counter."
(with-uxn (instance)
(let ((opcode (aref memory program-counter)))
(setf-16 program-counter (1+ program-counter))
(funcall (aref *opcode-dispatch-table* opcode) instance opcode)
(zerop opcode))))

203
src/op-functions.lisp Normal file
View file

@ -0,0 +1,203 @@
(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)

39
src/opcodes.lisp Normal file
View file

@ -0,0 +1,39 @@
(in-package :cl-uxn)
(defconstant +brk+ #x00)
(defconstant +jci+ #x20)
(defconstant +jmi+ #x40)
(defconstant +jsi+ #x60)
(defconstant +lit+ #x80)
(defconstant +inc+ #x01)
(defconstant +pop+ #x02)
(defconstant +nip+ #x03)
(defconstant +swp+ #x04)
(defconstant +rot+ #x05)
(defconstant +dup+ #x06)
(defconstant +ovr+ #x07)
(defconstant +equ+ #x08)
(defconstant +neq+ #x09)
(defconstant +gth+ #x0a)
(defconstant +lth+ #x0b)
(defconstant +jmp+ #x0c)
(defconstant +jcn+ #x0d)
(defconstant +jsr+ #x0e)
(defconstant +sth+ #x0f)
(defconstant +ldz+ #x10)
(defconstant +stz+ #x11)
(defconstant +ldr+ #x12)
(defconstant +str+ #x13)
(defconstant +lda+ #x14)
(defconstant +sta+ #x15)
(defconstant +dei+ #x16)
(defconstant +deo+ #x17)
(defconstant +add+ #x18)
(defconstant +sub+ #x19)
(defconstant +mul+ #x1a)
(defconstant +div+ #x1b)
(defconstant +and+ #x1c)
(defconstant +ora+ #x1d)
(defconstant +eor+ #x1e)
(defconstant +sft+ #x1f)

33
src/packages.lisp Normal file
View file

@ -0,0 +1,33 @@
(defpackage :cl-uxn
(:use :common-lisp)
(:export #:uxn
#:uxn-p
#:make-uxn
#:copy-uxn
#:uxn-memory
#:uxn-work-stack
#:uxn-return-stack
#:uxn-program-counter
#:uxn-stack
#:uxn-stack-p
#:make-uxn-stack
#:copy-uxn-stack
#:uxn-stack-buffer
#:uxn-stack-index
#:make-uxn-with-image
#:run
#:run-step
#:uxn-condition
#:uxn-breakpoint
#:uxn-watchpoint
#:address
#:old-value
#:new-value
#:*breakpoints*
#:*watchpoints*
#:*device-input*
#:*device-output*))