diff --git a/wip-duuqnd/user-side-compiler/high-level.lisp b/wip-duuqnd/user-side-compiler/high-level.lisp index 15bc2c8..7fdd12a 100644 --- a/wip-duuqnd/user-side-compiler/high-level.lisp +++ b/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)) - (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))) + (let ((*instruction-source* node)) + (loop :for ref :in (arguments node) + :for index :from 0 + :do (dereference ref) + :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 diff --git a/wip-duuqnd/user-side-compiler/instruction-list.txt b/wip-duuqnd/user-side-compiler/instruction-list.txt index 0ff29c8..d132354 100644 Binary files a/wip-duuqnd/user-side-compiler/instruction-list.txt and b/wip-duuqnd/user-side-compiler/instruction-list.txt differ diff --git a/wip-duuqnd/user-side-compiler/instruction.lisp b/wip-duuqnd/user-side-compiler/instruction.lisp index 900e103..af444d9 100644 --- a/wip-duuqnd/user-side-compiler/instruction.lisp +++ b/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,18 +35,20 @@ (defclass indirect-x-mixin (zero-page-mixin) ()) (defclass indirect-y-mixin (zero-page-mixin) ()) -(defun addressing-mode-to-class-name (mode-keyword) - (cadr (assoc mode-keyword - '((:implied implied-mixin) - (:immediate immediate-mixin) - (:zero-page zero-page-mixin) - (:zero-page-x zero-page-x-mixin) - (:zero-page-y zero-page-y-mixin) - (:absolute absolute-mixin) - (:absolute-x absolute-x-mixin) - (:absolute-y absolute-y-mixin) - (:indirect-x indirect-x-mixin) - (:indirect-y indirect-y-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) + (:absolute absolute-mixin) + (:absolute-x absolute-x-mixin) + (:absolute-y absolute-y-mixin) + (:indirect-x indirect-x-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))