diff options
| -rw-r--r-- | assembly.lisp | 92 | ||||
| -rw-r--r-- | cl-forth.lisp | 38 | ||||
| -rw-r--r-- | test/tests.lisp | 9 |
3 files changed, 99 insertions, 40 deletions
diff --git a/assembly.lisp b/assembly.lisp index 9cf7fca..fe07654 100644 --- a/assembly.lisp +++ b/assembly.lisp @@ -149,7 +149,10 @@ ,(cons 'list (c-stack->string (car forms)))))) (:string `((defop-format ,out-stream ,indent - ,(normalize-op-list forms))))))) + ,(normalize-op-list forms)))) + (:general `((progn ,@(mapcar (lambda (form) (replace-write out-stream indent + form)) + forms))))))) (defun expand-c (out-stream indent body) (mapcan #'(lambda (group) (expand-c-group group out-stream :indent indent)) @@ -192,20 +195,20 @@ (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))) + (collect (format nil "~a = pop();" 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);" + (collect (format nil "push(~a ~a ~a);" arg1 opstr (not-cl arg2))) (collect (format nil - "push(&stack, (~a ~a ~a) ? ~a : ~a);" + "push((~a ~a ~a) ? ~a : ~a);" arg1 opstr (not-cl arg2) (getf conds :ise) (getf conds :değilse)))))) - (collect (format nil "push(&stack, ~a);" x))))))))) + (collect (format nil "push(~a);" x))))))))) (defun comment-safe-str (str) "Handle newlines for comment" @@ -395,10 +398,85 @@ ;;; C operations (defop (push-int a) (:lex nil :targets :c) - ("push(&stack, ~d);" a)) + ("push(~d);" a)) ;; (defop (push-str a) (:lex nil :targets :c) ;; ("push(&stack, ~d);" a)) (defop dump (:targets :c) - ("printf(\"%d\\n\", pop(&stack));")) + ("printf(\"%d\\n\", pop());")) + +(defop (ise label-num) (:targets :c) + "rax = pop();" + ("if(!rax){ goto et_~a; }" label-num)) + +(defop (yoksa yap-num ise-num) (:indent 0 :targets :c) + (" goto et_~a;" yap-num) + ("et_~a:" ise-num)) + +(defop (yap label-num &optional döngü-num) (:indent 0 :targets :c) + (if (null döngü-num) + (:write ("et_~a:" label-num)) + (:write (" goto et_~a;" döngü-num) + ("et_~a:" label-num)))) + +(defop (iken label-num) (:targets :c) + "rax = pop();" + ("if(!rax){ goto et_~a; }" label-num)) + +(defop (döngü label-num) (:indent 0 :targets :c) + ("et_~a:" label-num)) + +(defop bel (:targets :c) + "push((uintptr_t) bel);") + +(defop oku (:targets :c) + "push(*((char*) pop()));") + +(defop yaz (:targets :c) + "rax = pop();" + "*((char*) pop()) = rax;") + +(defop (syscall num) (:lex nil :targets :c) + (iter (with call-regs = #("rdi" "rsi" "rdx" "r10" "r8" "r9")) + (initially (:write "rax = pop();")) + (for i from (- num 1) downto 0) + (:write ("~a = pop();" (aref call-regs i))) + (collect (aref call-regs i) into used-regs) + (finally (:write ("syscall(rax~{, ~a~});" (reverse used-regs)))))) + +(defun gen-c-stack (stream) + (format stream "~{~a~%~}" + '("#include <stdio.h>" + "#include <stdint.h>" + "" + "struct Stack {" + " uintptr_t content[1000000];" + " int i;" + "};" + "" + "typedef struct Stack Stack;" + "" + "Stack stack = { .i = 0 };" + "" + "void push(uintptr_t val){" + " stack.content[stack.i] = val;" + " stack.i += 1;" + "}" + "" + "uintptr_t pop(){" + " stack.i -= 1;" + " return stack.content[stack.i];" + "}" + "" + "uintptr_t rax, rbx, rcx, rdi, rsi, rdx, r10, r8, r9;" + "char bel[640000];" + ""))) + +(defmacro with-c-fn ((ret name) args out &body body) + `(let ((*print-case* :downcase)) + (format ,out "~a ~a(~{~a ~a~^, ~}){~%" ',ret ',name ',args) + ,@body + (format ,out "~&}~%"))) + + diff --git a/cl-forth.lisp b/cl-forth.lisp index 66327e5..88019ce 100644 --- a/cl-forth.lisp +++ b/cl-forth.lisp @@ -188,35 +188,11 @@ (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;~%}~%")) + (gen-c-stack out) + (with-c-fn (:int main) () out + (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) @@ -238,7 +214,9 @@ int main(void){ :output t :silence silence))) (defmethod compile-program ((target (eql :c)) path silence) - (run `("gcc" ,path) :output t :silence silence)) + (let ((name (first (uiop:split-string path :separator '(#\.))))) + (run `("gcc" ,path "-o" ,name) + :output t :silence silence))) diff --git a/test/tests.lisp b/test/tests.lisp index 2dfb4cb..6096bf4 100644 --- a/test/tests.lisp +++ b/test/tests.lisp @@ -34,7 +34,7 @@ (collect (read-line str))) (t (finish))))))) -(defun run-test (path) +(defun run-test (path &key (target :nasm)) "File must begin with 2 comments: First must be TEST Second must eval to the expected result" @@ -49,8 +49,11 @@ (return-from run-test 'not-test)) (let ((expected-output (eval (read-form-comment str)))) (generate-program (parse-tokens (lex-stream str)) - :path (change-file-type abs-path "asm") - :compile t :silence t) + :path (change-file-type abs-path (case target + (:nasm "asm") + (:c "c"))) + :compile t :silence t + :target target) (let ((output (run (list (drop-file-type abs-path)) :output :string :silence t))) (format t "testing ~a... " (pathname-name path)) |