diff options
| -rw-r--r-- | assembly.lisp | 170 | ||||
| -rw-r--r-- | cl-forth.lisp | 115 | ||||
| -rw-r--r-- | main.lisp | 2 |
3 files changed, 171 insertions, 116 deletions
diff --git a/assembly.lisp b/assembly.lisp index c1efe45..422ea6c 100644 --- a/assembly.lisp +++ b/assembly.lisp @@ -15,6 +15,8 @@ (find sym *psuedo-identifiers* :test #'string=))) (eval-always + (defparameter *targets* '(:nasm :c)) + (defun normalize-op-list (asm-list) (cons 'list (mapcar (lambda (el) (cond ((stringp el) el) @@ -67,12 +69,39 @@ ((listp form) (appending (op->string form))))))))) + (defparameter *stack-fn-assoc* '((:= :cmove) + (:> :cmovg) + (:< :cmovl))) + + (defun stack-unextend (stack) + "Turns an extended stack to body of a defop, second part of an extended stack is in the form of (:op arg1 arg2 :then val1 :else val2) which is asserted." + (multiple-value-bind (fst snd) (split-stack stack) + (assert (= 1 (length snd))) + (append (iter (for x in (reverse fst)) + (let ((*print-case* :downcase)) + (collect (format nil "pop ~a" x)))) + (let* ((push-part (car snd)) + (ifs (nthcdr 3 push-part))) + (list `(:mov rdx ,(getf ifs :ise)) + `(:mov rcx ,(getf ifs :değilse)) + `(:cmp ,(second push-part) ,(third push-part)) + `(,(cadr (assoc (car push-part) *stack-fn-assoc*)) + rcx rdx) + (format nil "push rcx")))))) + (defun syntax-of (form) (cond ((or (stringp form) (and (consp form) (stringp (car form)))) :string) ((and (listp form) (find '-- form)) - :stack) + (if (multiple-value-bind (fst snd) (split-stack form) + (declare (ignore fst)) + (and (consp snd) + (consp (car snd)) + (find (caar snd) *stack-fn-assoc* + :key #'car))) + :stack-extended + :stack)) ((and (listp form) (keywordp (car form))) :op) (t :general))) @@ -96,29 +125,60 @@ (defun expand-group (group out-stream &key (indent 4)) (destructuring-bind (syntax-type . forms) group (case syntax-type - (:stack `(defop-format ,out-stream ,indent - ,(cons 'list (mapcan (lambda (form) (stack->string form)) - forms)))) - (:op `(defop-format ,out-stream ,indent - ,(cons 'list (mapcar (lambda (form) (op->string form :push? nil)) - forms)))) - (:string `(defop-format ,out-stream ,indent - ,(normalize-op-list forms))) - (:general `(progn ,@(mapcar (lambda (form) (replace-write out-stream indent - form)) - forms))))))) - -(defmacro defop (op-name+args (&key (indent 4) (lex t)) &body body) + (:stack `((defop-format ,out-stream ,indent + ,(cons 'list (mapcan (lambda (form) (stack->string form)) + forms))))) + (:stack-extended (expand-nasm out-stream indent + (stack-unextend (car forms)))) + (:op `((defop-format ,out-stream ,indent + ,(cons 'list (mapcar (lambda (form) (op->string form :push? nil)) + forms))))) + (:string `((defop-format ,out-stream ,indent + ,(normalize-op-list forms)))) + (:general `((progn ,@(mapcar (lambda (form) (replace-write out-stream indent + form)) + forms))))))) + + (defun expand-nasm (out-stream indent body) + (mapcan #'(lambda (group) (expand-group group out-stream + :indent indent)) + (group-by-syntax body))) + + (defun expand-for-target (target out-stream body &optional (indent 4)) + (case target + (:nasm (expand-nasm out-stream indent body)) + (:c '(nil)))) + + (defun expand-method (target out-stream indent op-name args body) + (with-gensyms (_op _args _target) + (declare (ignorable _args)) + `(defmethod write-op + ((,_target (eql ,target)) ,out-stream + (,_op (eql ,(intern (string op-name) "KEYWORD"))) + ,_args) + ,@(if (null args) + (expand-for-target target out-stream body indent) + `((destructuring-bind ,args ,_args + ,@(expand-for-target target out-stream body indent)))))))) + +(defgeneric write-op (target stream op args) + (:documentation "Generate code for OP and ARGS and write it to STREAM according to the TARGET")) + +(defmacro defop (op-name+args (&key (indent 4) (lex t) (targets :nasm) + (as nil)) + &body body) + (declare (ignorable indent)) (with-gensyms (out-stream) (destructuring-bind (op-name . args) (mklist op-name+args) `(progn ,@(unless (null lex) `((push ',op-name *identifiers*))) - (setf (gethash ,(string op-name) *operations*) - (lambda (,out-stream ,@args) - ,@(mapcar #'(lambda (group) (expand-group group out-stream - :indent indent)) - (group-by-syntax body)))))))) + ,@(iter (for target in (if (eq :all targets) + *targets* + (mklist targets))) + (collect (expand-method target out-stream indent + (if (null as) op-name as) + args body))))))) ;;; TODO: Turn stack operation comments to DEFOP option, ;;; which then can be used by the user as a documentation @@ -126,15 +186,6 @@ ;;; the stack op documentation (this seems easily doable) ;;; Hopefully these two are done, need testing... -;; ( -- a) -(defop (push-int a) (:lex nil) - ("push ~d" a)) - -(defop (push-str len addr str) (:lex nil) - (progn (:write ("push ~d" len) - ("push str_~d" addr)) - (list :string addr str))) - (defop + () (rbx rax -- (:add rax rbx))) @@ -142,11 +193,7 @@ (rbx rax -- (:sub rbx rax))) (defop = () - (:mov rcx 0) - (:mov rdx 1) - (rbx rax -- ) - (:cmp rax rbx) - ( -- (:cmove rcx rdx))) + (rbx rax -- (:= rbx rax :ise 1 :değilse 0))) (defop eş () (rax -- rax rax)) @@ -155,32 +202,14 @@ (rax -- )) (defop < () - (:mov rcx 0) - (:mov rdx 1) - (rax rbx -- ) - (:cmp rax rbx) - ( -- (:cmovl rcx rdx))) + (rax rbx -- (:< rax rbx :ise 1 :değilse 0))) (defop > () - (:mov rcx 0) - (:mov rdx 1) - (rax rbx -- ) - (:cmp rax rbx) - ( -- (:cmovg rcx rdx))) + (rax rbx -- (:> rax rbx :ise 1 :değilse 0))) (defop bel () ( -- bel)) -(defop oku () - (rax -- ) - (:xor rbx rbx) - (:mov bl [rax]) - ( -- rbx)) - -(defop yaz () - (rax rbx -- ) - (:mov [rax] bl)) - (defop üst () (rbx rax -- rbx rax rbx)) @@ -196,12 +225,31 @@ (defop >> () (rbx rcx -- (:shr rbx cl))) -(defop "|" () +(defop "|" (:as pipe) (rbx rax -- (:or rbx rax))) (defop & () (rbx rax -- (:and rbx rax))) +(defop oku () + (rax -- ) + (:xor rbx rbx) + (:mov bl [rax]) + ( -- rbx)) + +(defop yaz () + (rax rbx -- ) + (:mov [rax] bl)) + +;; ( -- a) +(defop (push-int a) (:lex nil) + ("push ~d" a)) + +(defop (push-str len addr str) (:lex nil) + (progn (:write ("push ~d" len) + ("push str_~d" addr)) + (list :string addr str))) + (defop dump () "pop rdi" "call dump") @@ -257,12 +305,16 @@ (mapcar (lambda (x) (if (stringp x) (comment-safe-str x) x)) op))) +;; (defun gen-code (op str) +;; (let ((op-fn (gethash (string (car op)) *operations*))) +;; (when (null op-fn) +;; (error "~s is not a valid op" op)) +;; (gen-header op str) +;; (apply op-fn str (cdr op)))) + (defun gen-code (op str) - (let ((op-fn (gethash (string (car op)) *operations*))) - (when (null op-fn) - (error "~s is not a valid op" op)) - (gen-header op str) - (apply op-fn str (cdr op)))) + (gen-header op str) + (write-op :nasm str (car op) (cdr op))) (defun gen-dump (str) (format str "~{~a~%~}" diff --git a/cl-forth.lisp b/cl-forth.lisp index 1026253..ec7927f 100644 --- a/cl-forth.lisp +++ b/cl-forth.lisp @@ -28,40 +28,41 @@ (t (write-char ch str)))))) (defun lex-line (line &optional (line-num 0)) - (iter (with line-stream = (make-string-input-stream line)) - (with col = 0) - (with has-err = nil) - (for next-char = (peek-char nil line-stream nil nil)) - (until (null next-char)) - (let ((flag t)) - (cond ;; ((char= #\. next-char) - ;; (collect (make-token '|.| line-num col) into tokens) - ;; (read-char line-stream)) - ((char= #\| next-char) - (read-char line-stream) - (collect (make-token "|" line-num col :identifier) into tokens)) - ((char= #\Space next-char) (read-char line-stream)) - ((char= #\; next-char) ;; and not in string - (finish)) - ((char= #\" next-char) - (read-char line-stream) - (collect (make-token (read-string line-stream) - line-num col) - into tokens)) - (t (setf flag nil))) - (when flag - (incf col) - (next-iteration))) - (for next-sym in-stream line-stream - using #'read-preserving-whitespace) - (multiple-value-bind (token err) - (make-token next-sym line-num col) - (collect token into tokens) - (when err ;; skip line on error and continue lexing - (setf has-err t) - (finish)) - (incf col (length (princ-to-string next-sym)))) - (finally (return (values tokens has-err))))) + (let ((*package* (find-package "KEYWORD"))) + (iter (with line-stream = (make-string-input-stream line)) + (with col = 0) + (with has-err = nil) + (for next-char = (peek-char nil line-stream nil nil)) + (until (null next-char)) + (let ((flag t)) + (cond ;; ((char= #\. next-char) + ;; (collect (make-token '|.| line-num col) into tokens) + ;; (read-char line-stream)) + ((char= #\| next-char) + (read-char line-stream) + (collect (make-token :pipe line-num col :identifier) into tokens)) + ((char= #\Space next-char) (read-char line-stream)) + ((char= #\; next-char) ;; and not in string + (finish)) + ((char= #\" next-char) + (read-char line-stream) + (collect (make-token (read-string line-stream) + line-num col) + into tokens)) + (t (setf flag nil))) + (when flag + (incf col) + (next-iteration))) + (for next-sym in-stream line-stream + using #'read-preserving-whitespace) + (multiple-value-bind (token err) + (make-token next-sym line-num col) + (collect token into tokens) + (when err ;; skip line on error and continue lexing + (setf has-err t) + (finish)) + (incf col (length (princ-to-string next-sym)))) + (finally (return (values tokens has-err)))))) (defun lex-file (file-name &optional report-errors) (let ((has-error nil)) @@ -119,39 +120,39 @@ (let ((op (token-op token)) (op-type (getf (cdr token) :type))) (cond ((eq :number op-type) - (vector-push-extend `(push-int ,op) ops)) + (vector-push-extend `(:push-int ,op) ops)) ((eq :string op-type) - (vector-push-extend `(push-str ,(length op) ,i ,op) + (vector-push-extend `(:push-str ,(length op) ,i ,op) ops)) - ((string= 'ise op) - (push (list 'ise i) stack) - (vector-push-extend (list 'ise nil) ops)) - ((string= 'yoksa op) + ((string= :ise op) + (push (list :ise i) stack) + (vector-push-extend (list :ise nil) ops)) + ((string= :yoksa op) (let ((top (pop stack))) - (assert (string= 'ise (car top))) + (assert (string= :ise (car top))) (setf (second (aref ops (cadr top))) i) - (push (list 'yoksa i) stack) - (vector-push-extend (list 'yoksa nil i) ops))) - ((string= 'yap op) + (push (list :yoksa i) stack) + (vector-push-extend (list :yoksa nil i) ops))) + ((string= :yap op) (let ((top (pop stack))) - (cond ((find (car top) (list 'yoksa 'ise)) + (cond ((find (car top) (list :yoksa :ise)) (setf (second (aref ops (cadr top))) i) - (vector-push-extend (list 'yap i) ops)) - ((string= 'iken (car top)) + (vector-push-extend (list :yap i) ops)) + ((string= :iken (car top)) (setf (second (aref ops (cadr top))) i) - (vector-push-extend (list 'yap i (third top)) ops)) + (vector-push-extend (list :yap i (third top)) ops)) (t (error "yap cannot reference: ~a" (car top)))))) - ((string= 'döngü op) - (push (list 'döngü i) stack) - (vector-push-extend (list 'döngü i) ops)) - ((string= 'iken op) + ((string= :döngü op) + (push (list :döngü i) stack) + (vector-push-extend (list :döngü i) ops)) + ((string= :iken op) (let ((top (pop stack))) - (assert (string= 'döngü (car top))) - (push (list 'iken i (cadr top)) stack) - (vector-push-extend (list 'iken nil) ops))) + (assert (string= :döngü (car top))) + (push (list :iken i (cadr top)) stack) + (vector-push-extend (list :iken nil) ops))) ((search "syscall" (string-downcase (string op))) (let ((syscall-num (parse-integer (subseq (string op) 8)))) - (vector-push-extend (list 'syscall syscall-num) ops))) + (vector-push-extend (list :syscall syscall-num) ops))) (t (vector-push-extend (list op) ops)))) (finally (return ops)))) @@ -173,7 +174,7 @@ (let ((gen-val (gen-code op out))) (when (and (consp gen-val) (eq :string (car gen-val))) (push (cdr gen-val) strs)))) - (gen-code '(exit 0) out) + (gen-code '(:exit 0) out) (unless (null strs) (format out "segment .data~%") (dolist (str strs) @@ -15,6 +15,8 @@ (compile-program (second args))) ((string= flag "-i") (interpret-program (make-program (second args)))) + ((string= flag "-p") + (format t "~a" (make-program (second args)))) ((string= flag "-t") (run-tests)) (t (format t "~a is not a valid flag~%" flag)))))) |