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

@@ -1,11 +0,0 @@
-(in-package #:user-side-compiler)
-
-(defgeneric bytesquash (object)
-  (:method ((object integer))
-    (typecase object
-      ((unsigned-byte 8) (list object))
-      ((unsigned-byte 16) (list (ldb (byte 8 0) object)
-                                (ldb (byte 8 8) object)))
-      (t (error "Cannot bytesquash integers larger than 16-bit."))))
-  (:method ((object label))
-    (bytesquash (address object))))

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

@@ -1,8 +1,5 @@
 (in-package #:user-side-compiler)
 
-(defparameter *varvec* (make-label :name "VARVEC" :address #x8100))
-(defparameter *argvec* (make-label :name "ARGVEC" :address #xF0))
-
 (defvar *instruction-source* nil)
 (defvar *compile-result*)
 
@@ -47,7 +44,8 @@
     (format stream "@~D" (ref-index object))))
 
 (defmethod dereference ((ref reference-variable))
-  (produce-instruction 'inst-lda-absolute (make-offset-label *varvec* (ref-index ref))))
+  (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)))
@@ -76,7 +74,7 @@
     (loop :for ref :in (arguments node)
           :for index :from 0
           :do (dereference ref)
-          :do (produce-instruction 'inst-sta-absolute (make-offset-label *argvec* index)))
+          :do (produce-instruction 'inst-sta-absolute (format nil "ARGVEC+~D" index)))
     (produce-instruction 'inst-jsr-absolute (callee node))))
 
 (defclass node-branch (node)

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

@@ -32,14 +32,9 @@
                      ""
                      (format nil " ~S" (operand object)))))))
 
-(defclass complete-instruction-mixin ()
+(defclass complete-mixin ()
   ((%opcode :allocation :class :reader opcode :initarg :opcode)))
 
-(defmethod bytesquash ((object complete-instruction-mixin))
-  (append (list (opcode object))
-          (when (> (instruction-length object) 1)
-            (bytesquash (operand object)))))
-
 (defclass immediate-mixin () ())
 (defclass implied-mixin () ())
 (defclass accumulator-mixin () ())
@@ -74,12 +69,12 @@
                    (:indirect-y indirect-y-mixin))))))
 
 (defgeneric instruction-length (object)
-  (:method ((obj immediate-mixin)) 2)
+  (:method (immediate-mixin) 1)
-  (:method ((obj implied-mixin)) 1)
+  (:method (implied-mixin) 1)
-  (:method ((obj accumulator-mixin)) 1)
+  (:method (accumulator-mixin) 1)
-  (:method ((obj zero-page-mixin)) 2)
+  (:method (zero-page-mixin) 2)
-  (:method ((obj relative-mixin)) 2)
+  (:method (relative-mixin) 2)
-  (:method ((obj absolute-mixin)) 3))
+  (:method (absolute-mixin) 3))
 
 (defclass branching-mixin ()
   ((%branch-next :accessor branch-next :initarg :branch-next)))
@@ -90,64 +85,44 @@
     `(progn
        (defclass ,base-name (instruction)
          ((%mnemonic :allocation :class :initform ',mnemonic)))
-       (setf (slot-value (make-instance ',base-name) '%mnemonic) ',mnemonic)
        ,@(loop :for (mode code) :in modes-and-codes
-               :for class-name := (intern (format nil "INST-~A-~A" name mode))
+               :collect `(defclass ,(intern (format nil "INST-~A-~A"
-               :collect `(progn
+                                                    name mode))
-                           (defclass ,class-name
                              ,(append
                                `(,base-name
                                  ,(addressing-mode-to-class-name mode)
-                                   complete-instruction-mixin)
+                                 complete-mixin)
                                (when branching-p
                                  '(branching-mixin)))
-                             ((%opcode :allocation :class :initform ,code)))
+                           ((%opcode :allocation :class :initform ,code)))))))
-                           (setf (slot-value (allocate-instance (find-class ',class-name)) '%opcode) ,code))))))
 
 (defun fix-label-addresses-in-instruction-list (instruction-list origin)
   (loop :with address := origin
-        :with cell := instruction-list
         :for obj :in instruction-list
         :if (typep obj 'label)
           :do (setf (address obj) address)
         :else
-          :do (when (typep obj 'instruction)
+          :do (incf address (instruction-length obj))))
-                (incf address (instruction-length obj)))
-        :unless (null (rest cell))
-          :do (setf cell (rest cell))
-        :finally (setf (cdr cell)
-                       (list (make-label :name "PROGRAM_END" :address address)))))
-
-(defun bytesquash-instruction-list (instruction-list origin)
-  (let* ((end-label (find "PROGRAM_END" (remove-if-not #'labelp instruction-list)
-                          :key #'name :test #'equalp))
-         (byte-vector (make-array (- (address end-label) origin)
-                                  :element-type '(unsigned-byte 8)
-                                  :fill-pointer 0)))
-    (loop :for thing :in instruction-list
-          :when (typep thing 'instruction)
-            :do (dolist (byte (bytesquash thing))
-                  (vector-push byte byte-vector)))
-    byte-vector))
 
 ;;; Testing
 
-(define-instruction "TXA" nil (:implied #x8a))
+(define-instruction "TXA" nil (:implied 0))
-(define-instruction "PHA" nil (:implied #x48))
+(define-instruction "PHA" nil (:implied 0))
-(define-instruction "PLA" nil (:implied #x68))
+(define-instruction "PLA" nil (:implied 0))
-(define-instruction "TAX" nil (:implied #xaa))
+(define-instruction "TAX" nil (:implied 0))
-(define-instruction "DEX" nil (:implied #xca))
+(define-instruction "DEX" nil (:implied 0))
-(define-instruction "BNE" t (:relative #xd0))
+(define-instruction "BNE" t (:relative 0))
 (define-instruction "LDA" nil
-  (:immediate #xa9)
+  (:absolute 0)
-  (:zero-page #xa5)
+  (:zero-page 0)
-  (:absolute #xad)
+  (:immediate 0)
-  (:absolute-y #xb9))
+  (:absolute-y 0))
 (define-instruction "LDY" nil
-  (:immediate #xa0)
+  (:absolute 0)
-  (:absolute #xac))
+  (:immediate 0))
 (define-instruction "STA" nil
-  (:absolute #x8d)
+  (:absolute 0)
-  (:absolute-y #x99))
+  (:immediate 0)
+  (:absolute-y 0))
 (define-instruction "JSR" nil
-  (:absolute #x20))
+  (:absolute 0))

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

@@ -4,9 +4,6 @@
   ((%name :accessor name :initarg :name)
    (%address :accessor address :initform nil :initarg :address)))
 
-(defun labelp (obj)
-  (typep obj 'label))
-
 (defmethod print-object ((object label) stream)
   (with-accessors ((name name) (address address)) object
     (print-unreadable-object (object stream :type t)
@@ -20,28 +17,9 @@
   (format nil "~A~D" prefix (incf *label-counter*)))
 
 (defun make-label (&key name name-prefix address)
+  (when (null name)
+    (setf name (make-label-name (if (null name-prefix) "L" name-prefix))))
   (when (and (not (null name)) (not (null name-prefix)))
     (warn "MAKE-LABEL with both name (~A) and prefix (~A) specified (useless)."
           name name-prefix))
-  (when (null name)
-    (setf name (make-label-name (if (null name-prefix) "L" name-prefix))))
   (make-instance 'label :name name :address address))
-
-(defclass offset-label (label)
-  ((%offset-from :accessor offset-from :initarg :offset-from)
-   (%offset :accessor offset :initarg :offset)))
-
-(defmethod address ((object offset-label))
-  (+ (address (offset-from object))
-     (offset object)))
-
-(defmethod name ((object offset-label))
-  (format nil "~A~C~D"
-          (name (offset-from object))
-          (if (minusp (offset object))
-              #\-
-              #\+)
-          (offset object)))
-
-(defun make-offset-label (src-label offset)
-  (make-instance 'offset-label :offset-from src-label :offset offset))