diff options
Diffstat (limited to 'assembly.lisp')
| -rw-r--r-- | assembly.lisp | 159 |
1 files changed, 105 insertions, 54 deletions
diff --git a/assembly.lisp b/assembly.lisp index 422ea6c..9cf7fca 100644 --- a/assembly.lisp +++ b/assembly.lisp @@ -1,7 +1,5 @@ (in-package :cl-forth) -(defparameter *operations* (make-hash-table :test 'equal)) - (defparameter *psuedo-identifiers* '(syscall-1 syscall-2 syscall-3 syscall-4 syscall-5 syscall-6) "These do not map to operations directly, but are valid to lexer") @@ -122,7 +120,7 @@ (reverse cur))) acc)))))) - (defun expand-group (group out-stream &key (indent 4)) + (defun expand-nasm-group (group out-stream &key (indent 4)) (destructuring-bind (syntax-type . forms) group (case syntax-type (:stack `((defop-format ,out-stream ,indent @@ -140,14 +138,27 @@ forms))))))) (defun expand-nasm (out-stream indent body) - (mapcan #'(lambda (group) (expand-group group out-stream + (mapcan #'(lambda (group) (expand-nasm-group group out-stream :indent indent)) (group-by-syntax body))) + + (defun expand-c-group (group out-stream &key (indent 4)) + (destructuring-bind (syntax-type . forms) group + (case syntax-type + ((:stack :stack-extended) `((defop-format ,out-stream ,indent + ,(cons 'list + (c-stack->string (car forms)))))) + (:string `((defop-format ,out-stream ,indent + ,(normalize-op-list forms))))))) + + (defun expand-c (out-stream indent body) + (mapcan #'(lambda (group) (expand-c-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)))) + (:c (expand-c out-stream indent body)))) (defun expand-method (target out-stream indent op-name args body) (with-gensyms (_op _args _target) @@ -159,12 +170,67 @@ ,@(if (null args) (expand-for-target target out-stream body indent) `((destructuring-bind ,args ,_args - ,@(expand-for-target target out-stream body indent)))))))) + ,@(expand-for-target target out-stream body indent))))))) + + ;;hack, because there is no cl in C only nasm + (defun not-cl (sym) + (if (eq 'cl sym) + 'rcx + sym)) + + (defparameter *c-ops* '((:add "+") + (:sub "-") + (:shl "<<") + (:shr ">>") + (:or "|") + (:and "&") + (:< "<") + (:> ">") + (:= "=="))) + + (defun c-stack->string (stack) + (multiple-value-bind (prev next) (split-stack stack) + (let ((*print-case* :downcase)) + (append (iter (for x in (reverse prev)) + (collect (format nil "~a = pop(&stack);" x))) + (iter (for x in next) + (if (and (consp x) (assoc (car x) *c-ops*)) + (destructuring-bind (op arg1 arg2 . conds) x + (let ((opstr (cadr (assoc op *c-ops*)))) + (if (null conds) + (collect (format nil "push(&stack, ~a ~a ~a);" + arg1 opstr (not-cl arg2))) + (collect (format nil + "push(&stack, (~a ~a ~a) ? ~a : ~a);" + arg1 opstr (not-cl arg2) + (getf conds :ise) + (getf conds :değilse)))))) + (collect (format nil "push(&stack, ~a);" x))))))))) -(defgeneric write-op (target stream op args) - (:documentation "Generate code for OP and ARGS and write it to STREAM according to the TARGET")) +(defun comment-safe-str (str) + "Handle newlines for comment" + (with-output-to-string (new-str) + (iter (for ch in-string str with-index i) + (cond ((> i 10) + (princ "..." new-str) + (finish)) + ((char= #\Newline ch) + (princ "\\n" new-str)) + (t (write-char ch new-str)))))) -(defmacro defop (op-name+args (&key (indent 4) (lex t) (targets :nasm) +(defgeneric write-op (target stream op args) + (:documentation "Generate code for OP and ARGS and write it to STREAM according to the TARGET. WRITE-OP methods are defined by the DEFOP macro.") + (:method :before ((target (eql :nasm)) stream op args) + (format stream " ;; -- ~s --~%" + (mapcar (lambda (x) (if (stringp x) (comment-safe-str x) x)) + (cons op args)))) + (:method :before ((target (eql :c)) stream op args) + (format stream "~% /* ~s */~%" + ;; comment-safe is probably not necessary with multiline comments + (mapcar (lambda (x) (if (stringp x) (comment-safe-str x) x)) + (cons op args))))) + +(defmacro defop (op-name+args (&key (indent 4) (lex t) (targets *targets*) (as nil)) &body body) (declare (ignorable indent)) @@ -173,9 +239,7 @@ `(progn ,@(unless (null lex) `((push ',op-name *identifiers*))) - ,@(iter (for target in (if (eq :all targets) - *targets* - (mklist targets))) + ,@(iter (for target in (mklist targets)) (collect (expand-method target out-stream indent (if (null as) op-name as) args body))))))) @@ -207,9 +271,6 @@ (defop > () (rax rbx -- (:> rax rbx :ise 1 :değilse 0))) -(defop bel () - ( -- bel)) - (defop üst () (rbx rax -- rbx rax rbx)) @@ -231,91 +292,70 @@ (defop & () (rbx rax -- (:and rbx rax))) -(defop oku () + + +;;; NASM operations +(defop bel (:targets :nasm) + ( -- bel)) + +(defop oku (:targets :nasm) (rax -- ) (:xor rbx rbx) (:mov bl [rax]) ( -- rbx)) -(defop yaz () +(defop yaz (:targets :nasm) (rax rbx -- ) (:mov [rax] bl)) ;; ( -- a) -(defop (push-int a) (:lex nil) +(defop (push-int a) (:lex nil :targets :nasm) ("push ~d" a)) -(defop (push-str len addr str) (:lex nil) +(defop (push-str len addr str) (:lex nil :targets :nasm) (progn (:write ("push ~d" len) ("push str_~d" addr)) (list :string addr str))) -(defop dump () +(defop dump (:targets :nasm) "pop rdi" "call dump") -(defop (exit code) (:lex nil) +(defop (exit code) (:lex nil :targets :nasm) "mov rax, 60" ("mov rdi, ~a" code) "syscall") -(defop (ise label-num) () +(defop (ise label-num) (:targets :nasm) "pop rax" "test rax, rax" ("jz et_~a" label-num)) -(defop (yoksa yap-num ise-num) (:indent 0) +(defop (yoksa yap-num ise-num) (:indent 0 :targets :nasm) (" jmp et_~a" yap-num) ("et_~a:" ise-num)) -(defop (yap label-num &optional döngü-num) (:indent 0) +(defop (yap label-num &optional döngü-num) (:indent 0 :targets :nasm) (if (null döngü-num) (:write ("et_~a:" label-num)) (:write (" jmp et_~a" döngü-num) ("et_~a:" label-num)))) -(defop (iken label-num) () +(defop (iken label-num) (:targets :nasm) "pop rax" "test rax, rax" ("jz et_~a" label-num)) -(defop (döngü label-num) (:indent 0) +(defop (döngü label-num) (:indent 0 :targets :nasm) ("et_~a:" label-num)) -(defop (syscall num) (:lex nil) +(defop (syscall num) (:lex nil :targets :nasm) (iter (with call-regs = #("rdi" "rsi" "rdx" "r10" "r8" "r9")) (initially (:write "pop rax")) (for i from (- num 1) downto 0) (:write ("pop ~a" (aref call-regs i))) (finally (:write "syscall")))) -(defun comment-safe-str (str) - "Handle newlines for asm comment" - (with-output-to-string (new-str) - (iter (for ch in-string str with-index i) - (cond ((> i 10) - (princ "..." new-str) - (finish)) - ((char= #\Newline ch) - (princ "\\n" new-str)) - (t (write-char ch new-str)))))) - -(defun gen-header (op str) - (format str " ;; -- ~s --~%" - (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) - (gen-header op str) - (write-op :nasm str (car op) (cdr op))) - (defun gen-dump (str) (format str "~{~a~%~}" '("dump:" @@ -351,3 +391,14 @@ " syscall" " add rsp, 40" " ret"))) + + +;;; C operations +(defop (push-int a) (:lex nil :targets :c) + ("push(&stack, ~d);" a)) + +;; (defop (push-str a) (:lex nil :targets :c) +;; ("push(&stack, ~d);" a)) + +(defop dump (:targets :c) + ("printf(\"%d\\n\", pop(&stack));")) |