Begin C code generation.

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))
 
 
diff --git a/main.lisp b/main.lisp
index 0b29edb..182d748 100644
--- a/main.lisp
+++ b/main.lisp
@@ -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")