defop uses generic functions now. extended stack syntax

3 files changed, 171 insertions, 116 deletions

diff --git a/assembly.lisp b/assembly.lisp
index c1efe45..422ea6c 100644
--- a/assembly.lisp
+++ b/assembly.lisp
@@ -15,6 +15,8 @@
       (find sym *psuedo-identifiers* :test #'string=)))
 
 (eval-always
+  (defparameter *targets* '(:nasm :c))
+
   (defun normalize-op-list (asm-list)
     (cons 'list
           (mapcar (lambda (el) (cond ((stringp el) el)
@@ -67,12 +69,39 @@
                             ((listp form)
                              (appending (op->string form)))))))))
 
+  (defparameter *stack-fn-assoc* '((:= :cmove)
+                                   (:> :cmovg)
+                                   (:< :cmovl)))
+  
+  (defun stack-unextend (stack)
+    "Turns an extended stack to body of a defop, second part of an extended stack is in the form of (:op arg1 arg2 :then val1 :else val2) which is asserted."
+    (multiple-value-bind (fst snd) (split-stack stack)
+      (assert (= 1 (length snd)))
+      (append (iter (for x in (reverse fst))
+                    (let ((*print-case* :downcase))
+                      (collect (format nil "pop ~a" x))))
+              (let* ((push-part (car snd))
+                     (ifs (nthcdr 3 push-part)))
+                (list `(:mov rdx ,(getf ifs :ise))
+                      `(:mov rcx ,(getf ifs :değilse))
+                      `(:cmp ,(second push-part) ,(third push-part))
+                      `(,(cadr (assoc (car push-part) *stack-fn-assoc*))
+                        rcx rdx)
+                      (format nil "push rcx"))))))
+  
   (defun syntax-of (form)
     (cond ((or (stringp form)
                (and (consp form) (stringp (car form))))
            :string)
           ((and (listp form) (find '-- form))
-           :stack)
+           (if (multiple-value-bind (fst snd) (split-stack form)
+                 (declare (ignore fst))
+                 (and (consp snd)
+                      (consp (car snd))
+                      (find (caar snd) *stack-fn-assoc*
+                            :key #'car)))
+               :stack-extended
+               :stack))
           ((and (listp form) (keywordp (car form)))
            :op)
           (t :general)))
@@ -96,29 +125,60 @@
   (defun expand-group (group out-stream &key (indent 4))
     (destructuring-bind (syntax-type . forms) group
       (case syntax-type
-        (:stack `(defop-format ,out-stream ,indent
-                   ,(cons 'list (mapcan (lambda (form) (stack->string form))
-                                        forms))))
-        (:op `(defop-format ,out-stream ,indent
-                ,(cons 'list (mapcar (lambda (form) (op->string form :push? nil))
-                                     forms))))
-        (:string `(defop-format ,out-stream ,indent
-                    ,(normalize-op-list forms)))
-        (:general `(progn ,@(mapcar (lambda (form) (replace-write out-stream indent
-                                                             form))
-                                    forms)))))))
-
-(defmacro defop (op-name+args (&key (indent 4) (lex t)) &body body)
+        (:stack `((defop-format ,out-stream ,indent
+                     ,(cons 'list (mapcan (lambda (form) (stack->string form))
+                                          forms)))))
+        (:stack-extended (expand-nasm out-stream indent
+                                      (stack-unextend (car forms))))
+        (:op `((defop-format ,out-stream ,indent
+                  ,(cons 'list (mapcar (lambda (form) (op->string form :push? nil))
+                                       forms)))))
+        (:string `((defop-format ,out-stream ,indent
+                      ,(normalize-op-list forms))))
+        (:general `((progn ,@(mapcar (lambda (form) (replace-write out-stream indent
+                                                               form))
+                                      forms)))))))
+
+  (defun expand-nasm (out-stream indent body)
+    (mapcan #'(lambda (group) (expand-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))))
+  
+  (defun expand-method (target out-stream indent op-name args body)
+    (with-gensyms (_op _args _target)
+      (declare (ignorable _args))
+      `(defmethod write-op
+           ((,_target (eql ,target)) ,out-stream
+            (,_op (eql ,(intern (string op-name) "KEYWORD")))
+            ,_args)
+         ,@(if (null args)
+               (expand-for-target target out-stream body indent)
+               `((destructuring-bind ,args ,_args
+                   ,@(expand-for-target target out-stream body indent))))))))
+
+(defgeneric write-op (target stream op args)
+  (:documentation "Generate code for OP and ARGS and write it to STREAM according to the TARGET"))
+
+(defmacro defop (op-name+args (&key (indent 4) (lex t) (targets :nasm)
+                                 (as nil))
+                 &body body)
+  (declare (ignorable indent))
   (with-gensyms (out-stream)
     (destructuring-bind (op-name . args) (mklist op-name+args)
       `(progn
          ,@(unless (null lex)
              `((push ',op-name *identifiers*)))
-         (setf (gethash ,(string op-name) *operations*)
-               (lambda (,out-stream ,@args)
-                 ,@(mapcar #'(lambda (group) (expand-group group out-stream
-                                                      :indent indent))
-                           (group-by-syntax body))))))))
+         ,@(iter (for target in (if (eq :all targets)
+                                    *targets*
+                                    (mklist targets)))
+                 (collect (expand-method target out-stream indent
+                                         (if (null as) op-name as)
+                                         args body)))))))
 
 ;;; TODO: Turn stack operation comments to DEFOP option,
 ;;;       which then can be used by the user as a documentation
@@ -126,15 +186,6 @@
 ;;;       the stack op documentation (this seems easily doable)
 ;;; Hopefully these two are done, need testing...
 
-;; ( -- a)
-(defop (push-int a) (:lex nil)
-  ("push ~d" a))
-
-(defop (push-str len addr str) (:lex nil)
-  (progn (:write ("push ~d" len)
-                 ("push str_~d" addr))
-         (list :string addr str)))
-
 (defop + ()
   (rbx rax -- (:add rax rbx)))
 
@@ -142,11 +193,7 @@
   (rbx rax -- (:sub rbx rax)))
 
 (defop = ()
-  (:mov rcx 0)
-  (:mov rdx 1)
-  (rbx rax -- )
-  (:cmp rax rbx)
-  ( -- (:cmove rcx rdx)))
+  (rbx rax -- (:= rbx rax :ise 1 :değilse 0)))
 
 (defop eş ()
   (rax -- rax rax))
@@ -155,32 +202,14 @@
   (rax -- ))
 
 (defop < ()
-  (:mov rcx 0)
-  (:mov rdx 1)
-  (rax rbx -- )
-  (:cmp rax rbx)
-  ( -- (:cmovl rcx rdx)))
+  (rax rbx -- (:< rax rbx :ise 1 :değilse 0)))
 
 (defop > ()
-  (:mov rcx 0)
-  (:mov rdx 1)
-  (rax rbx -- )
-  (:cmp rax rbx)
-  ( -- (:cmovg rcx rdx)))
+  (rax rbx -- (:> rax rbx :ise 1 :değilse 0)))
 
 (defop bel ()
   ( -- bel))
 
-(defop oku ()
-  (rax -- )
-  (:xor rbx rbx)
-  (:mov bl [rax])
-  ( -- rbx))
-
-(defop yaz ()
-  (rax rbx -- )
-  (:mov [rax] bl))
-
 (defop üst ()
   (rbx rax -- rbx rax rbx))
 
@@ -196,12 +225,31 @@
 (defop >> ()
   (rbx rcx -- (:shr rbx cl)))
 
-(defop "|" ()
+(defop "|" (:as pipe)
   (rbx rax -- (:or rbx rax)))
 
 (defop & ()
   (rbx rax -- (:and rbx rax)))
 
+(defop oku ()
+  (rax -- )
+  (:xor rbx rbx)
+  (:mov bl [rax])
+  ( -- rbx))
+
+(defop yaz ()
+  (rax rbx -- )
+  (:mov [rax] bl))
+
+;; ( -- a)
+(defop (push-int a) (:lex nil)
+  ("push ~d" a))
+
+(defop (push-str len addr str) (:lex nil)
+  (progn (:write ("push ~d" len)
+                 ("push str_~d" addr))
+         (list :string addr str)))
+
 (defop dump ()
   "pop rdi"
   "call dump")
@@ -257,12 +305,16 @@
           (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)
-  (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))))
+  (gen-header op str)
+  (write-op :nasm str (car op) (cdr op)))
 
 (defun gen-dump (str)
   (format str "~{~a~%~}"
diff --git a/cl-forth.lisp b/cl-forth.lisp
index 1026253..ec7927f 100644
--- a/cl-forth.lisp
+++ b/cl-forth.lisp
@@ -28,40 +28,41 @@
                 (t (write-char ch str))))))
 
 (defun lex-line (line &optional (line-num 0))
-  (iter (with line-stream = (make-string-input-stream line))
-        (with col = 0)
-        (with has-err = nil)
-        (for next-char = (peek-char nil line-stream nil nil))
-        (until (null next-char))
-        (let ((flag t))
-          (cond ;; ((char= #\. next-char)
-            ;;  (collect (make-token '|.| line-num col) into tokens)
-            ;;  (read-char line-stream))
-            ((char= #\|  next-char)
-             (read-char line-stream)
-             (collect (make-token "|" line-num col :identifier) into tokens))
-            ((char= #\Space next-char) (read-char line-stream))
-            ((char= #\; next-char) ;; and not in string
-             (finish))
-            ((char= #\" next-char)
-             (read-char line-stream)
-             (collect (make-token (read-string line-stream)
-                                  line-num col)
-               into tokens))
-            (t (setf flag nil)))
-          (when flag
-            (incf col)
-            (next-iteration)))
-        (for next-sym in-stream line-stream
-             using #'read-preserving-whitespace)
-        (multiple-value-bind (token err)
-            (make-token next-sym line-num col)
-          (collect token into tokens)
-          (when err ;; skip line on error and continue lexing
-            (setf has-err t)
-            (finish))
-          (incf col (length (princ-to-string next-sym))))
-        (finally (return (values tokens has-err)))))
+  (let ((*package* (find-package "KEYWORD")))
+    (iter (with line-stream = (make-string-input-stream line))
+          (with col = 0)
+          (with has-err = nil)
+          (for next-char = (peek-char nil line-stream nil nil))
+          (until (null next-char))
+          (let ((flag t))
+            (cond ;; ((char= #\. next-char)
+              ;;  (collect (make-token '|.| line-num col) into tokens)
+              ;;  (read-char line-stream))
+              ((char= #\|  next-char)
+               (read-char line-stream)
+               (collect (make-token :pipe line-num col :identifier) into tokens))
+              ((char= #\Space next-char) (read-char line-stream))
+              ((char= #\; next-char) ;; and not in string
+               (finish))
+              ((char= #\" next-char)
+               (read-char line-stream)
+               (collect (make-token (read-string line-stream)
+                                    line-num col)
+                 into tokens))
+              (t (setf flag nil)))
+            (when flag
+              (incf col)
+              (next-iteration)))
+          (for next-sym in-stream line-stream
+               using #'read-preserving-whitespace)
+          (multiple-value-bind (token err)
+              (make-token next-sym line-num col)
+            (collect token into tokens)
+            (when err ;; skip line on error and continue lexing
+              (setf has-err t)
+              (finish))
+            (incf col (length (princ-to-string next-sym))))
+          (finally (return (values tokens has-err))))))
 
 (defun lex-file (file-name &optional report-errors)
   (let ((has-error nil))
@@ -119,39 +120,39 @@
         (let ((op (token-op token))
               (op-type (getf (cdr token) :type)))
           (cond ((eq :number op-type)
-                 (vector-push-extend `(push-int ,op) ops))
+                 (vector-push-extend `(:push-int ,op) ops))
                 ((eq :string op-type)
-                 (vector-push-extend `(push-str ,(length op) ,i ,op)
+                 (vector-push-extend `(:push-str ,(length op) ,i ,op)
                                      ops))
-                ((string= 'ise op)
-                 (push (list 'ise i) stack)
-                 (vector-push-extend (list 'ise nil) ops))
-                ((string= 'yoksa op)
+                ((string= :ise op)
+                 (push (list :ise i) stack)
+                 (vector-push-extend (list :ise nil) ops))
+                ((string= :yoksa op)
                  (let ((top (pop stack)))
-                   (assert (string= 'ise (car top)))
+                   (assert (string= :ise (car top)))
                    (setf (second (aref ops (cadr top))) i)
-                   (push (list 'yoksa i) stack)
-                   (vector-push-extend (list 'yoksa nil i) ops)))
-                ((string= 'yap op)
+                   (push (list :yoksa i) stack)
+                   (vector-push-extend (list :yoksa nil i) ops)))
+                ((string= :yap op)
                  (let ((top (pop stack)))
-                   (cond ((find (car top) (list 'yoksa 'ise))
+                   (cond ((find (car top) (list :yoksa :ise))
                           (setf (second (aref ops (cadr top))) i)
-                          (vector-push-extend (list 'yap i) ops))
-                         ((string= 'iken (car top))
+                          (vector-push-extend (list :yap i) ops))
+                         ((string= :iken (car top))
                           (setf (second (aref ops (cadr top))) i)
-                          (vector-push-extend (list 'yap i (third top)) ops))
+                          (vector-push-extend (list :yap i (third top)) ops))
                          (t (error "yap cannot reference: ~a" (car top))))))
-                ((string= 'döngü op)
-                 (push (list 'döngü i) stack)
-                 (vector-push-extend (list 'döngü i) ops))
-                ((string= 'iken op)
+                ((string= :döngü op)
+                 (push (list :döngü i) stack)
+                 (vector-push-extend (list :döngü i) ops))
+                ((string= :iken op)
                  (let ((top (pop stack)))
-                   (assert (string= 'döngü (car top)))
-                   (push (list 'iken i (cadr top)) stack)
-                   (vector-push-extend (list 'iken nil) ops)))
+                   (assert (string= :döngü (car top)))
+                   (push (list :iken i (cadr top)) stack)
+                   (vector-push-extend (list :iken nil) ops)))
                 ((search "syscall" (string-downcase (string op)))
                  (let ((syscall-num (parse-integer (subseq (string op) 8))))
-                   (vector-push-extend (list 'syscall syscall-num) ops)))
+                   (vector-push-extend (list :syscall syscall-num) ops)))
                 (t (vector-push-extend (list op) ops))))
         (finally (return ops))))
 
@@ -173,7 +174,7 @@
           (let ((gen-val (gen-code op out)))
             (when (and (consp gen-val) (eq :string (car gen-val)))
               (push (cdr gen-val) strs))))
-         (gen-code '(exit 0) out)
+         (gen-code '(:exit 0) out)
          (unless (null strs)
            (format out "segment .data~%")
            (dolist (str strs)
diff --git a/main.lisp b/main.lisp
index 701aa9e..0b29edb 100644
--- a/main.lisp
+++ b/main.lisp
@@ -15,6 +15,8 @@
              (compile-program (second args)))
             ((string= flag "-i")
              (interpret-program (make-program (second args))))
+            ((string= flag "-p")
+             (format t "~a" (make-program (second args))))
             ((string= flag "-t")
              (run-tests))
             (t (format t "~a is not a valid flag~%" flag))))))