126 lines
4.3 KiB
Common Lisp
126 lines
4.3 KiB
Common Lisp
(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 produce-label (&optional label)
|
|
(when (null label)
|
|
(setf label (make-label)))
|
|
(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)))
|
|
|
|
(defclass reference () ())
|
|
|
|
(defgeneric ref-constantp (reference) (:method (reference) nil))
|
|
|
|
(defclass reference-constant (reference)
|
|
((%value :accessor ref-value :initarg :value)))
|
|
|
|
(defmethod ref-constantp ((reference reference-constant))
|
|
t)
|
|
|
|
(defmethod print-object ((object reference-constant) stream)
|
|
(print-unreadable-object (object stream :type t)
|
|
(format stream "~D" (ref-value object))))
|
|
|
|
(defmethod dereference ((ref reference-constant))
|
|
(produce-instruction 'inst-lda-immediate (ref-value ref)))
|
|
|
|
(defclass reference-variable (reference)
|
|
((%index :accessor ref-index :initarg :index)))
|
|
|
|
(defmethod print-object ((object reference-variable) stream)
|
|
(print-unreadable-object (object stream :type t)
|
|
(format stream "@~D" (ref-index object))))
|
|
|
|
(defmethod dereference ((ref reference-variable))
|
|
(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)))
|
|
|
|
(defmethod generate-code :before ((node node))
|
|
(format t ";; ~A~%" node))
|
|
|
|
(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)))
|
|
|
|
(defmethod print-object ((object node-call) stream)
|
|
(print-unreadable-object (object stream :type t :identity t)
|
|
(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 (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 ((*instruction-source* node)
|
|
(else-label (make-label :name-prefix "ELSE")))
|
|
(produce-instruction 'inst-lda-absolute "RESULT")
|
|
(produce-instruction 'inst-bne-relative else-label)
|
|
;; The THEN branch
|
|
(compile-node (branch-next node))
|
|
;; The ELSE branch
|
|
(produce-label else-label)))
|
|
|
|
(defclass node-dotimes (node)
|
|
((%stop-ref :accessor stop-ref :initarg :stop-ref
|
|
:documentation "A reference giving a value of how many times to run the loop.")
|
|
(%loopee-node :accessor loopee-node :initarg :loopee-node)))
|
|
|
|
(defmethod generate-code ((node node-dotimes))
|
|
(let ((*instruction-source* node)
|
|
(loop-label (make-label :name-prefix "LOOPBACK")))
|
|
(produce-instruction 'inst-txa-implied)
|
|
(produce-instruction 'inst-pha-implied)
|
|
|
|
(dereference (stop-ref node))
|
|
(produce-instruction 'inst-tax-implied)
|
|
(produce-label loop-label)
|
|
(compile-node (loopee-node node))
|
|
(produce-instruction 'inst-dex-implied)
|
|
(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* '()))
|
|
(compile-node node)
|
|
(nreverse *compile-result*)))
|
|
|
|
(defun make-call (callee args)
|
|
(let ((arguments
|
|
(loop :for (constp value) :in args
|
|
:with index := -1
|
|
:if constp
|
|
:collect (make-instance 'reference-constant :value value)
|
|
:else
|
|
:collect (make-instance 'reference-variable :index (incf index)))))
|
|
(make-instance 'node-call :callee callee
|
|
:arguments arguments)))
|