Replace the text assembly in high-level with instruction objects

wip-duuqnd/user-side-compiler/high-level.lisp

@@ -1,10 +1,22 @@
 (in-package #:user-side-compiler)
 
 (defvar *label-counter* 0)
+(defvar *instruction-source* nil)
+(defvar *compile-result*)
+
+(defun produce-instruction (instruction-class &optional operand)
+  (push (make-instance instruction-class :operand operand :source *instruction-source*)
+        *compile-result*))
 
 (defun genlabel (&optional (prefix "L"))
   (format nil "~A~D" prefix (incf *label-counter*)))
 
+(defun produce-label (&optional label)
+  (when (null label)
+    (setf label (genlabel)))
+  (push label *compile-result*)
+  label)
+
 (defmacro format-inst (destination control-string &rest format-arguments)
   `(format ,destination "~C~A~%" #\Tab (format nil ,control-string ,@format-arguments)))
 
@@ -23,7 +35,7 @@
     (format stream "~D" (ref-value object))))
 
 (defmethod dereference ((ref reference-constant))
-  (format-inst t "LDA #~D" (ref-value ref)))
+  (produce-instruction 'inst-lda-immediate (ref-value ref)))
 
 (defclass reference-variable (reference)
   ((%index :accessor ref-index :initarg :index)))
@@ -33,8 +45,8 @@
     (format stream "@~D" (ref-index object))))
 
 (defmethod dereference ((ref reference-variable))
-  (format-inst t "LDY #~D" (ref-index ref))
-  (format-inst t "LDA VARVEC,Y"))
+  (produce-instruction 'inst-ldy-immediate (ref-index ref))
+  (produce-instruction 'inst-lda-absolute-y "VARVEC"))
 
 (defclass node ()
   ((%next :accessor next :accessor normal-next :initform nil)))
@@ -45,6 +57,11 @@
 (defmethod generate-code :after ((node node))
   (terpri))
 
+(defmethod compile-node ((node node))
+  (generate-code node)
+  (unless (null (next node))
+    (compile-node (next node))))
+
 (defclass node-call (node)
   ((%callee :accessor callee :initarg :callee)
    (%arguments :accessor arguments :initarg :arguments)))
@@ -54,23 +71,25 @@
     (format stream "~A~A" (callee object) (arguments object))))
 
 (defmethod generate-code ((node node-call))
+  (let ((*instruction-source* node))
     (loop :for ref :in (arguments node)
           :for index :from 0
           :do (dereference ref)
-        :do (format-inst t "STA ARGVEC+~D" index))
-  (format-inst t "JSR ~A" (callee node)))
+          :do (produce-instruction 'inst-sta-absolute (format nil "ARGVEC+~D" index)))
+    (produce-instruction 'inst-jsr-absolute (callee node))))
 
 (defclass node-branch (node)
   ((%branch-next :accessor branch-next :initarg :branch-next)))
 
 (defmethod generate-code ((node node-branch))
-  (let ((else-label (genlabel "ELSE")))
-    (format-inst t "LDA RESULT")
-    (format-inst t "BNE ~A" else-label)
+  (let ((*instruction-source* node)
+        (else-label (genlabel "ELSE")))
+    (produce-instruction 'inst-lda-absolute "RESULT")
+    (produce-instruction 'inst-bne-zero-page else-label)
     ;; The THEN branch
-    (generate-code (branch-next node))
+    (compile-node (branch-next node))
     ;; The ELSE branch
-    (format t "~%~A:~%" else-label)))
+    (produce-label else-label)))
 
 (defclass node-dotimes (node)
   ((%stop-ref :accessor stop-ref :initarg :stop-ref
@@ -78,24 +97,25 @@
    (%loopee-node :accessor loopee-node :initarg :loopee-node)))
 
 (defmethod generate-code ((node node-dotimes))
-  (format-inst t "TXA")
-  (format-inst t "PHA")
+  (let ((*instruction-source* node)
+        (loop-label (genlabel "LOOPBACK")))
+    (produce-instruction 'inst-txa-implied)
+    (produce-instruction 'inst-pha-implied)
 
-  (let ((loop-label (genlabel "LOOPBACK")))
     (dereference (stop-ref node))
-    (format-inst t "TAX")
-    (format t "~%~A:~%" loop-label)
-    (generate-code (loopee-node node))
-    (format-inst t "DEX")
-    (format-inst t "BNE ~A" loop-label))
+    (produce-instruction 'inst-tax-implied)
+    (produce-label loop-label)
+    (compile-node (loopee-node node))
+    (produce-instruction 'inst-dex-implied)
+    (produce-instruction 'inst-bne-zero-page loop-label)
 
-  (format-inst t "PLA")
-  (format-inst t "TAX"))
+    (produce-instruction 'inst-pla-implied)
+    (produce-instruction 'inst-tax-implied)))
 
 (defmethod compile-starting-at ((node node))
-  (generate-code node)
-  (unless (null (next node))
-    (compile-starting-at (next node))))
+  (let ((*compile-result* '()))
+    (compile-node node)
+    (nreverse *compile-result*)))
 
 (defun make-call (callee args)
   (let ((arguments

wip-duuqnd/user-side-compiler/instruction.lisp

@@ -5,18 +5,28 @@
 (defclass instruction ()
   ((%mnemonic :allocation :class :reader mnemonic :initarg :mnemonic)
    (%operand :accessor operand :initarg :operand)
-   (%next :accessor next :accessor normal-next :initarg :next)))
+   (%next :accessor next :accessor normal-next :initarg :next)
+   (%source :accessor source :initarg :source :initform nil)))
+
+(defmethod print-object ((object instruction) stream)
+  (format stream "#<~A~A>" (mnemonic object)
+          (if (or (typep object 'implied-mixin)
+                  (typep object 'accumulator-mixin))
+              ""
+              (format nil " ~S" (operand object)))))
 
 (defclass complete-mixin ()
   ((%opcode :allocation :class :reader opcode :initarg :opcode)))
 
 (defclass immediate-mixin () ())
 (defclass implied-mixin () ())
+(defclass accumulator-mixin () ())
 (defclass zero-page-mixin () ())
 
 (defmethod shared-initialize :after ((instance zero-page-mixin) slot-names &rest initargs &key &allow-other-keys)
   (declare (ignore slot-names initargs))
-  (assert (< (operand instance) #x100)))
+  (when (numberp (operand instance))
+    (assert (< (operand instance) #x100))))
 
 (defclass zero-page-x-mixin (zero-page-mixin) ())
 (defclass absolute-mixin () ())
@@ -25,10 +35,12 @@
 (defclass indirect-x-mixin (zero-page-mixin) ())
 (defclass indirect-y-mixin (zero-page-mixin) ())
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
   (defun addressing-mode-to-class-name (mode-keyword)
     (cadr (assoc mode-keyword
                  '((:implied implied-mixin)
                    (:immediate immediate-mixin)
+                   (:accumulator accumulator-mixin)
                    (:zero-page zero-page-mixin)
                    (:zero-page-x zero-page-x-mixin)
                    (:zero-page-y zero-page-y-mixin)
@@ -36,7 +48,7 @@
                    (:absolute-x absolute-x-mixin)
                    (:absolute-y absolute-y-mixin)
                    (:indirect-x indirect-x-mixin)
-                 (:indirect-y indirect-y-mixin)))))
+                   (:indirect-y indirect-y-mixin))))))
 
 (defclass branching-mixin ()
   ((%branch-next :accessor branch-next :initarg :branch-next)))
@@ -57,3 +69,26 @@
                                (when branching-p
                                  '(branching-mixin)))
                            ((%opcode :allocation :class :initform ,code)))))))
+
+;;; Testing
+
+(define-instruction "TXA" nil (:implied 0))
+(define-instruction "PHA" nil (:implied 0))
+(define-instruction "PLA" nil (:implied 0))
+(define-instruction "TAX" nil (:implied 0))
+(define-instruction "DEX" nil (:implied 0))
+(define-instruction "BNE" t (:zero-page 0))
+(define-instruction "LDA" nil
+  (:absolute 0)
+  (:zero-page 0)
+  (:immediate 0)
+  (:absolute-y 0))
+(define-instruction "LDY" nil
+  (:absolute 0)
+  (:immediate 0))
+(define-instruction "STA" nil
+  (:absolute 0)
+  (:immediate 0)
+  (:absolute-y 0))
+(define-instruction "JSR" nil
+  (:absolute 0))