From 5bcf47053f8a09f5d526283e4ebea51aa3b81f91 Mon Sep 17 00:00:00 2001
From: skittles <skittles@noreply.localhost>
Date: Wed, 29 Jan 2025 05:21:25 -0300
Subject: [PATCH] First working implementation

---
 cl-uxn.asd            |  12 +++
 src/helpers.lisp      |  21 +++++
 src/main.lisp         | 121 +++++++++++++++++++++++++
 src/op-functions.lisp | 203 ++++++++++++++++++++++++++++++++++++++++++
 src/opcodes.lisp      |  39 ++++++++
 src/packages.lisp     |  33 +++++++
 6 files changed, 429 insertions(+)
 create mode 100644 cl-uxn.asd
 create mode 100644 src/helpers.lisp
 create mode 100644 src/main.lisp
 create mode 100644 src/op-functions.lisp
 create mode 100644 src/opcodes.lisp
 create mode 100644 src/packages.lisp

diff --git a/cl-uxn.asd b/cl-uxn.asd
new file mode 100644
index 0000000..a8d2d83
--- /dev/null
+++ b/cl-uxn.asd
@@ -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")
diff --git a/src/helpers.lisp b/src/helpers.lisp
new file mode 100644
index 0000000..74265ef
--- /dev/null
+++ b/src/helpers.lisp
@@ -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))
diff --git a/src/main.lisp b/src/main.lisp
new file mode 100644
index 0000000..2cb1989
--- /dev/null
+++ b/src/main.lisp
@@ -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))))
diff --git a/src/op-functions.lisp b/src/op-functions.lisp
new file mode 100644
index 0000000..8475407
--- /dev/null
+++ b/src/op-functions.lisp
@@ -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)
diff --git a/src/opcodes.lisp b/src/opcodes.lisp
new file mode 100644
index 0000000..245b9bd
--- /dev/null
+++ b/src/opcodes.lisp
@@ -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)
diff --git a/src/packages.lisp b/src/packages.lisp
new file mode 100644
index 0000000..139594f
--- /dev/null
+++ b/src/packages.lisp
@@ -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*))