simyager/kurt
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added ops for C codegen

Browse Source
This commit is contained in:
mRnea
2024-08-09 11:41:14 +03:00
parent 1056b74b11
commit b574944656
3 changed files with 99 additions and 40 deletions
Download Patch File Download Diff File Expand all files Collapse all files

92
assembly.lisp
View File

@@ -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 "~&}~%")))

34
cl-forth.lisp
View File

@@ -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;
")
(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;~%}~%"))
(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)))

9
test/tests.lisp
View File

@@ -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))