defop uses generic functions now. extended stack syntax

1 files changed, 111 insertions, 59 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~%~}"