added ops for C codegen

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

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
+  (gen-c-stack out)
-          "#include <stdio.h>
+  (with-c-fn (:int main) () out
-
-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;~%}~%"))
+    (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)))
 
 
 

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")
+                          :path (change-file-type abs-path (case target
-                          :compile t :silence t)
+                                                             (: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))