Add function to compute addresses of labels in instruction list

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

@@ -1,6 +1,5 @@
 (in-package #:user-side-compiler)
 
-(defvar *label-counter* 0)
 (defvar *instruction-source* nil)
 (defvar *compile-result*)
 
@@ -8,15 +7,15 @@
   (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)))
+    (setf label (make-label)))
   (push label *compile-result*)
   label)
 
+(defun produce-comment (text)
+  (push text *compile-result*))
+
 (defmacro format-inst (destination control-string &rest format-arguments)
   `(format ,destination "~C~A~%" #\Tab (format nil ,control-string ,@format-arguments)))
 
@@ -52,7 +51,7 @@
   ((%next :accessor next :accessor normal-next :initform nil)))
 
 (defmethod generate-code :before ((node node))
-  (format t ";; ~A~%" node))
+  (produce-comment (format nil "~A" node)))
 
 (defmethod generate-code :after ((node node))
   (terpri))
@@ -83,9 +82,9 @@
 
 (defmethod generate-code ((node node-branch))
   (let ((*instruction-source* node)
-        (else-label (genlabel "ELSE")))
+        (else-label (make-label :name-prefix "ELSE")))
     (produce-instruction 'inst-lda-absolute "RESULT")
-    (produce-instruction 'inst-bne-zero-page else-label)
+    (produce-instruction 'inst-bne-relative else-label)
     ;; The THEN branch
     (compile-node (branch-next node))
     ;; The ELSE branch
@@ -98,7 +97,7 @@
 
 (defmethod generate-code ((node node-dotimes))
   (let ((*instruction-source* node)
-        (loop-label (genlabel "LOOPBACK")))
+        (loop-label (make-label :name-prefix "LOOPBACK")))
     (produce-instruction 'inst-txa-implied)
     (produce-instruction 'inst-pha-implied)
 
@@ -107,13 +106,14 @@
     (produce-label loop-label)
     (compile-node (loopee-node node))
     (produce-instruction 'inst-dex-implied)
-    (produce-instruction 'inst-bne-zero-page loop-label)
+    (produce-instruction 'inst-bne-relative loop-label)
 
     (produce-instruction 'inst-pla-implied)
     (produce-instruction 'inst-tax-implied)))
 
 (defmethod compile-starting-at ((node node))
-  (let ((*compile-result* '()))
+  (let ((*compile-result* '())
+        (*label-counter* 0))
     (compile-node node)
     (nreverse *compile-result*)))
 

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

@@ -9,11 +9,28 @@
    (%source :accessor source :initarg :source :initform nil)))
 
 (defmethod print-object ((object instruction) stream)
+  (cond ((some (lambda (type)
+                 (typep object type))
+               '(immediate-mixin accumulator-mixin zero-page-mixin absolute-mixin))
+         (format stream "#<~A ~A~A~A>"
+                 (mnemonic object)
+                 (typecase object
+                   (immediate-mixin "#")
+                   ((member indirect-y-mixin indirect-x-mixin) "(")
+                   (t ""))
+                 (typecase object
+                   (accumulator-mixin "A")
+                   (t (operand object)))
+                 (typecase object
+                   (indirect-x-mixin ", X)")
+                   (indirect-y-mixin "),Y")
+                   (t ""))))
+        (t
          (format stream "#<~A~A>" (mnemonic object)
                  (if (or (typep object 'implied-mixin)
                          (typep object 'accumulator-mixin))
                      ""
-              (format nil " ~S" (operand object)))))
+                     (format nil " ~S" (operand object)))))))
 
 (defclass complete-mixin ()
   ((%opcode :allocation :class :reader opcode :initarg :opcode)))
@@ -44,12 +61,21 @@
                    (:zero-page zero-page-mixin)
                    (:zero-page-x zero-page-x-mixin)
                    (:zero-page-y zero-page-y-mixin)
+                   (:relative relative-mixin)
                    (:absolute absolute-mixin)
                    (:absolute-x absolute-x-mixin)
                    (:absolute-y absolute-y-mixin)
                    (:indirect-x indirect-x-mixin)
                    (:indirect-y indirect-y-mixin))))))
 
+(defgeneric instruction-length (object)
+  (:method (immediate-mixin) 1)
+  (:method (implied-mixin) 1)
+  (:method (accumulator-mixin) 1)
+  (:method (zero-page-mixin) 2)
+  (:method (relative-mixin) 2)
+  (:method (absolute-mixin) 3))
+
 (defclass branching-mixin ()
   ((%branch-next :accessor branch-next :initarg :branch-next)))
 
@@ -70,6 +96,14 @@
                                  '(branching-mixin)))
                            ((%opcode :allocation :class :initform ,code)))))))
 
+(defun fix-label-addresses-in-instruction-list (instruction-list origin)
+  (loop :with address := origin
+        :for obj :in instruction-list
+        :if (typep obj 'label)
+          :do (setf (address obj) address)
+        :else
+          :do (incf address (instruction-length obj))))
+
 ;;; Testing
 
 (define-instruction "TXA" nil (:implied 0))
@@ -77,7 +111,7 @@
 (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 "BNE" t (:relative 0))
 (define-instruction "LDA" nil
   (:absolute 0)
   (:zero-page 0)

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

@@ -0,0 +1,25 @@
+(in-package #:user-side-compiler)
+
+(defclass label ()
+  ((%name :accessor name :initarg :name)
+   (%address :accessor address :initform nil :initarg :address)))
+
+(defmethod print-object ((object label) stream)
+  (with-accessors ((name name) (address address)) object
+    (print-unreadable-object (object stream :type t)
+      (write-string name stream)
+      (unless (null address)
+        (format stream " @ 0x~4,'0X" address)))))
+
+(defvar *label-counter* 0)
+
+(defun make-label-name (prefix)
+  (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))
+  (make-instance 'label :name name :address address))

wip-duuqnd/user-side-compiler/user-side-compiler.asd

@@ -4,5 +4,6 @@
   :serial t
   :components
   ((:file "package")
+   (:file "label")
    (:file "high-level")
    (:file "instruction")))