diff options
| -rw-r--r-- | assembly.lisp | 86 | ||||
| -rw-r--r-- | cl-forth.lisp | 85 |
2 files changed, 120 insertions, 51 deletions
diff --git a/assembly.lisp b/assembly.lisp index bdee15c..1522643 100644 --- a/assembly.lisp +++ b/assembly.lisp @@ -3,23 +3,38 @@ (defparameter *operations* (make-hash-table)) (eval-always - (defun normalize-op-list (lst) + (defun normalize-op-list (asm-list) (cons 'list (mapcar (lambda (el) (cond ((stringp el) el) ((listp el) `(format nil ,@el)))) - lst)))) + asm-list))) -(defmacro defop (op-name (&key (indent 4) args) &body asm-strings) - `(setf (gethash ',op-name *operations*) - (lambda (out-stream ,@args) - (format out-stream - ,(format nil "~~{~a~~a~~%~~}" - (make-string indent :initial-element - #\Space)) - ,(normalize-op-list asm-strings))))) + (defun defop-format (str space-num asm-list) + (format str + (format nil "~~{~a~~a~~%~~}" + (make-string space-num :initial-element #\Space)) + asm-list)) + (defun replace-write (out-stream indent forms) + (if (consp forms) + (if (eq :write (car forms)) + `(defop-format ,out-stream ,indent + ,(normalize-op-list (cdr forms))) + (cons (replace-write out-stream indent (car forms)) + (replace-write out-stream indent (cdr forms)))) + forms))) -(defop push (:args (a)) +(defmacro defop (op-name+args (&key (indent 4)) &body body) + (with-gensyms (out-stream) + (destructuring-bind (op-name . args) (mklist op-name+args) + `(setf (gethash ',op-name *operations*) + (lambda (,out-stream ,@args) + ,(if (or (stringp (car body)) (stringp (caar body))) + `(defop-format ,out-stream ,indent + ,(normalize-op-list body)) + (replace-write out-stream indent (car body)))))))) + +(defop (push a) () ("push ~d" a)) (defop + () @@ -34,7 +49,7 @@ "sub rbx, rax" "push rbx") -(defop |.| () +(defop dump () "pop rdi" "call dump") @@ -47,23 +62,60 @@ "cmove rcx, rdx" "push rcx") -(defop exit (:args (exit-code)) +(defop (exit code) () "mov rax, 60" - ("mov rdi, ~a" exit-code) + ("mov rdi, ~a" code) "syscall") -(defop ise (:args (label-num)) +(defop (ise label-num) () "pop rax" "test rax, rax" ("jz et_~a" label-num)) -(defop yoksa (:args (yap-num ise-num) :indent 0) +(defop (yoksa yap-num ise-num) (:indent 0) (" jmp et_~a" yap-num) ("et_~a:" ise-num)) -(defop yap (:args (label-num) :indent 0) +(defop (yap label-num &optional döngü-num) (:indent 0) + (if (null döngü-num) + (:write ("et_~a:" label-num)) + (:write (" jmp et_~a" döngü-num) + ("et_~a:" label-num)))) + +(defop eş () + "pop rax" + "push rax" + "push rax") + +(defop düş () + "pop rax") + +(defop (iken label-num) () + "pop rax" + "test rax, rax" + ("jz et_~a" label-num)) + +(defop (döngü label-num) (:indent 0) ("et_~a:" label-num)) +(defop < () + "mov rcx, 0" + "mov rdx, 1" + "pop rbx" + "pop rax" + "cmp rax, rbx" + "cmovl rcx, rdx" + "push rcx") + +(defop > () + "mov rcx, 0" + "mov rdx, 1" + "pop rbx" + "pop rax" + "cmp rax, rbx" + "cmovg rcx, rdx" + "push rcx") + (defun gen-code (op str) (let ((op-fn (gethash (car op) *operations*))) (if (null op-fn) diff --git a/cl-forth.lisp b/cl-forth.lisp index f7ea66e..a87d0eb 100644 --- a/cl-forth.lisp +++ b/cl-forth.lisp @@ -2,7 +2,7 @@ (eval-always (defparameter *identifiers* - '(+ - |.| = ise yoksa yap eş push değiş üst rot düş)) + '(+ - dump = ise yoksa yap eş push değiş üst rot düş döngü iken < >)) (defun is-identifier (sym) (find sym *identifiers*))) @@ -14,6 +14,7 @@ (defun token-op (token) (car token)) +;;; LEXER (defun lex-line (line &optional (line-num 0)) (iter (with line-stream = (make-string-input-stream line)) (with col = 0) @@ -21,13 +22,13 @@ (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= #\Space next-char) (read-char line-stream)) - ((char= #\; next-char) ;; and not in string - (finish)) - (t (setf flag nil))) + (cond ;; ((char= #\. next-char) + ;; (collect (make-token '|.| line-num col) into tokens) + ;; (read-char line-stream)) + ((char= #\Space next-char) (read-char line-stream)) + ((char= #\; next-char) ;; and not in string + (finish)) + (t (setf flag nil))) (when flag (incf col) (next-iteration))) @@ -64,34 +65,42 @@ (appending tokens)))) has-error))) -;; (defun prog-from-tokens (tokens) -;; (iter (for token in tokens) -;; (let ((op (token-op token))) -;; (cond ((numberp op) -;; (collect `(push ,op) result-type 'vector)) -;; (t (collect (list op) result-type 'vector)))))) - +;;; PARSER (defun parse-tokens (tokens) (iter (with ops = (make-array (length tokens) :fill-pointer 0 :adjustable t)) - (with if-stack = ()) + (with stack = ()) (for i from 0) (for token in tokens) (let ((op (token-op token))) (cond ((numberp op) (vector-push-extend `(push ,op) ops)) ((eq 'ise op) - (push i if-stack) + (push (list 'ise i) stack) (vector-push-extend (list 'ise nil) ops)) ((eq 'yoksa op) - (let ((current (pop if-stack))) - (setf (second (aref ops current)) i) - (push i if-stack) + (let ((top (pop stack))) + (assert (eq 'ise (car top))) + (setf (second (aref ops (cadr top))) i) + (push (list 'yoksa i) stack) (vector-push-extend (list 'yoksa nil i) ops))) ((eq 'yap op) - (let ((current (pop if-stack))) - (setf (second (aref ops current)) i) - (vector-push-extend (list 'yap i) ops))) + (let ((top (pop stack))) + (cond ((find (car top) (list 'yoksa 'ise)) + (setf (second (aref ops (cadr top))) i) + (vector-push-extend (list 'yap i) ops)) + ((eq 'iken (car top)) + (setf (second (aref ops (cadr top))) i) + (vector-push-extend (list 'yap i (third top)) ops)) + (t (error "yap cannot reference: ~a" (car top)))))) + ((eq 'döngü op) + (push (list 'döngü i) stack) + (vector-push-extend (list 'döngü i) ops)) + ((eq 'iken op) + (let ((top (pop stack))) + (assert (eq 'döngü (car top))) + (push (list 'iken i (cadr top)) stack) + (vector-push-extend (list 'iken nil) ops))) (t (vector-push-extend (list op) ops)))) (finally (return ops)))) @@ -102,17 +111,19 @@ (error "Can't generate program due to error during lexing")) (parse-tokens tokens))) -;; (defun *ops* '(push pop minus dump)) -(define-condition op-not-implemented (style-warning) - ((undef-ops :initarg :ops :reader undef-ops)) - (:report (lambda (condition stream) - (format stream "These ops are not defined in op-case: ~s" - (undef-ops condition))))) -(defun identifier-coverage (defined-ops) - (let ((undef-ops (set-difference *identifiers* defined-ops))) - (unless (null undef-ops) - (warn (make-condition 'op-not-implemented :ops undef-ops))))) +;;; INTERPRETER +(eval-always + (define-condition op-not-implemented (style-warning) + ((undef-ops :initarg :ops :reader undef-ops)) + (:report (lambda (condition stream) + (format stream "These ops are not defined in op-case: ~s" + (undef-ops condition))))) + + (defun identifier-coverage (defined-ops) + (let ((undef-ops (set-difference *identifiers* defined-ops))) + (unless (null undef-ops) + (warn (make-condition 'op-not-implemented :ops undef-ops)))))) (defmacro op-case (case-form &body body) (iter (for (op-id) in body) @@ -178,6 +189,9 @@ ;; rot, rot ;; drop, düşür + + +;;; COMPILER (defun gen-header (op str) (format str " ;; -- ~s --~%" op)) @@ -203,5 +217,8 @@ (defun compile-program (path) (generate-program (make-program path) :compile t)) - +(defun assembly-undefined-ops () + (iter (for (k) in-hashtable *operations*) + (collect k into defops) + (finally (return (set-difference *identifiers* defops))))) |