diff options
| -rw-r--r-- | assembly.lisp | 159 | ||||
| -rw-r--r-- | cl-forth.lisp | 83 | ||||
| -rw-r--r-- | main.lisp | 2 |
3 files changed, 169 insertions, 75 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));")) diff --git a/cl-forth.lisp b/cl-forth.lisp index ec7927f..66327e5 100644 --- a/cl-forth.lisp +++ b/cl-forth.lisp @@ -164,38 +164,81 @@ (parse-tokens tokens))) ;;; COMPILER -(defun write-program (program out &key (mem-cap 640000)) +;;(defgeneric write-program (target program stream)) +(defmethod write-program ((target (eql :nasm)) program out + &key (mem-cap 640000)) (format out "~a~%" "segment .text") (gen-dump out) (format out "~{~a~%~}" '("global _start" "_start:")) (let ((strs nil)) (iter (for op in-sequence program) - (let ((gen-val (gen-code op out))) + (let ((gen-val (write-op target out (car op) (cdr op)))) (when (and (consp gen-val) (eq :string (car gen-val))) (push (cdr gen-val) strs)))) - (gen-code '(:exit 0) out) - (unless (null strs) - (format out "segment .data~%") - (dolist (str strs) - (format out "str_~a: db ~{0x~x~^,~}~%" - (first str) - (map 'list #'char-code (second str)))))) + (write-op target out :exit '(0)) + (unless (null strs) + (format out "segment .data~%") + (dolist (str strs) + (format out "str_~a: db ~{0x~x~^,~}~%" + (first str) + (map 'list #'char-code (second str)))))) (format out "~a~%" "segment .bss") (format out "~a ~a~%" "bel: resb" mem-cap)) -(defun generate-program (program &key (path "output.asm") (compile nil) - (mem-cap 640000) (silence nil)) - (with-open-file (out path :direction :output - :if-exists :supersede) - (write-program program out :mem-cap mem-cap)) +(defmethod write-program ((target (eql :c)) program out &key (mem-cap 640000)) + (declare (ignore mem-cap)) + (format out + "#include <stdio.h> + +struct Stack { + int content[100]; + int i; +}; + +typedef struct Stack Stack; + +void push(Stack* stack, int val){ + stack->content[stack->i] = val; + stack->i += 1; +} + +int pop(Stack* stack){ + stack->i -= 1; + return stack->content[stack->i]; +} + +Stack stack; +int rax, rbx; + +int main(void){ + stack.i = 0; +") + (iter (for op in-sequence program) + (write-op target out (car op) (cdr op))) + (format out " return 0;~%}~%")) + +(defun generate-program (program + &key (path "output.asm") (compile nil) + (mem-cap 640000) (silence nil) (target :nasm)) + (with-open-file (out path :direction :output :if-exists :supersede) + (write-program target program out :mem-cap mem-cap)) (when compile - (run `("nasm" "-felf64" ,path) :output t :silence silence) - (let ((name (first (uiop:split-string path :separator '(#\.))))) - (run `("ld" "-o" ,name ,(concatenate 'string name ".o")) - :output t :silence silence)))) + (compile-program target path silence))) + +(defgeneric compile-program (target path silence)) +(setf (documentation #'compile-program 'function) + (format nil "Produces the executable from source code, targets are ~a" + *targets*)) + +(defmethod compile-program ((target (eql :nasm)) path silence) + (run `("nasm" "-felf64" ,path) :output t :silence silence) + (let ((name (first (uiop:split-string path :separator '(#\.))))) + (run `("ld" "-o" ,name ,(concatenate 'string name ".o")) + :output t :silence silence))) + +(defmethod compile-program ((target (eql :c)) path silence) + (run `("gcc" ,path) :output t :silence silence)) -(defun compile-program (path) - (generate-program (make-program path) :compile t)) @@ -12,7 +12,7 @@ ;; (let ((program (prog-from-tokens tokens))) ;; (format t "~s~%" program) ;; (generate-program program :compile t))) - (compile-program (second args))) + (generate-program (make-program (second args)) :compile t)) ((string= flag "-i") (interpret-program (make-program (second args)))) ((string= flag "-p") |