massive overhaul to defop, temporarily disable interpretation

assembly.lisp

@@ -2,6 +2,18 @@
 
 (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")
+
+(defparameter *identifiers* ())
+;; '(+ - dump = ise yoksa yap eş push değiş üst rot düş döngü iken < >
+;;   bel oku yaz >> << & "|")
+
+(defun is-identifier (sym)
+  (or (find sym *identifiers* :test #'string=)
+      (find sym *psuedo-identifiers* :test #'string=)))
+
 (eval-always
   (defun normalize-op-list (asm-list)
     (cons 'list
@@ -22,55 +34,175 @@
                ,(normalize-op-list (cdr forms)))
             (cons (replace-write out-stream indent (car forms))
                   (replace-write out-stream indent (cdr forms))))
-        forms)))
+        forms))
 
-(defmacro defop (op-name+args (&key (indent 4)) &body body)
+  (defun add-indent (indent fmt-string)
+    (format nil "~a~a"
+            (make-string indent :initial-element #\Space)
+            fmt-string))
+
+  (defun split-stack (stack)
+    (let ((split-num (position '-- stack)))
+      (values (butlast stack (- (length stack) split-num))
+              (nthcdr (+ 1 split-num) stack))))
+
+  (defun op->string (asm-instruction &key (push? t))
+    "asm-instruction is something like (:add rax rbx)"
+    (destructuring-bind (op arg1 arg2) asm-instruction
+      (let ((*print-case* :downcase))
+        (if (null push?)
+            (format nil (format nil "~a ~a, ~a" op arg1 arg2))
+            (list (format nil "~a ~a, ~a" op arg1 arg2)
+                  (format nil "push ~a" arg1))))))
+
+  (defun stack->string (stack)
+    (multiple-value-bind (prev next) 
+        (split-stack stack)
+      (let ((*print-case* :downcase))
+        (append (iter (for sym in (reverse prev))
+                      (collect (format nil "pop ~a" sym)))
+                (iter (for form in next)
+                      (cond ((symbolp form)
+                             (appending (list (format nil "push ~a" form))))
+                            ((listp form)
+                             (appending (op->string form)))))))))
+
+  (defun syntax-of (form)
+    (cond ((or (stringp form)
+               (and (consp form) (stringp (car form))))
+           :string)
+          ((and (listp form) (find '-- form))
+           :stack)
+          ((and (listp form) (keywordp (car form)))
+           :op)
+          (t :general)))
+
+  (defun group-by-syntax (forms &optional (syntax nil) (cur ()) (acc ()))
+    (when (null forms)
+      (return-from group-by-syntax
+        (cdr (reverse (append (list (cons (syntax-of (car cur))
+                                          (reverse cur)))
+                              acc)))))
+    (let* ((form (car forms))
+           (form-syntax (syntax-of form)))
+      (cond ((eq syntax form-syntax)
+             (group-by-syntax (cdr forms) syntax
+                              (cons form cur) acc))
+            (t (group-by-syntax (cdr forms) form-syntax
+                                (list form) (append (list (cons syntax
+                                                                (reverse cur)))
+                                                    acc))))))
+
+  (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)
   (with-gensyms (out-stream)
     (destructuring-bind (op-name . args) (mklist op-name+args)
-      `(setf (gethash ,(string op-name) *operations*)
-             (lambda (,out-stream ,@args)
-               ,(if (or (stringp (car body)) (stringp (caar body)))
-                    `(defop-format ,out-stream ,indent
-                              ,(normalize-op-list body))
-                    (replace-write out-stream indent (car body))))))))
+      `(progn
+         ,@(append
+            (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))))))))))
 
 ;;; TODO: Turn stack operation comments to DEFOP option,
 ;;;       which then can be used by the user as a documentation
 ;;; TODO: Better yet, generate the asm code directly from
 ;;;       the stack op documentation (this seems easily doable)
+;;; Hopefully these two are done, need testing...
 
 ;; ( -- a)
-(defop (push a) ()
+(defop (push a) (:lex nil)
   ("push ~d" a))
 
-;; (rbx rax -- (rbx + rax))
 (defop + ()
-  "pop rax"
-  "pop rbx"
-  "add rax, rbx"
-  "push rax")
+  (rbx rax -- (:add rax rbx)))
 
-;; (rbx rax -- (rbx - rax))
 (defop - ()
-  "pop rax"
-  "pop rbx"
-  "sub rbx, rax"
-  "push rbx")
+  (rbx rax -- (:sub rbx rax)))
+
+(defop = ()
+  (:mov rcx 0)
+  (:mov rdx 1)
+  (rbx rax -- )
+  (:cmp rax rbx)
+  ( -- (:cmove rcx rdx)))
+
+(defop eş ()
+  (rax -- rax rax))
+
+(defop düş ()
+  (rax -- ))
+
+(defop < ()
+  (:mov rcx 0)
+  (:mov rdx 1)
+  (rax rbx -- )
+  (:cmp rax rbx)
+  ( -- (:cmovl rcx rdx)))
+
+(defop > ()
+  (:mov rcx 0)
+  (:mov rdx 1)
+  (rax rbx -- )
+  (:cmp rax rbx)
+  ( -- (:cmovg rcx rdx)))
+
+(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))
+
+(defop rot ()
+  (rcx rbx rax -- rbx rax rcx))
+
+(defop değiş ()
+  (rbx rax -- rax rbx))
+
+(defop << ()
+  (rbx rcx -- (:shl rbx cl)))
+
+(defop >> ()
+  (rbx rcx -- (:shr rbx cl)))
+
+(defop "|" ()
+  (rbx rcx -- (:or rbx cl)))
+
+(defop & ()
+  (rbx rcx -- (:and rbx cl)))
 
 (defop dump ()
   "pop rdi"
   "call dump")
 
-(defop = ()
-  "mov rcx, 0"
-  "mov rdx, 1"
-  "pop rax"
-  "pop rbx"
-  "cmp rax, rbx"
-  "cmove rcx, rdx"
-  "push rcx")
-
-(defop (exit code) ()
+(defop (exit code) (:lex nil)
   "mov rax, 60"
   ("mov rdi, ~a" code)
   "syscall")
@@ -90,16 +222,6 @@
       (:write ("    jmp et_~a" döngü-num)
               ("et_~a:" label-num))))
 
-;; (rax -- rax rax)
-(defop eş ()
-  "pop rax"
-  "push rax"
-  "push rax")
-
-;; (rax -- )
-(defop düş ()
-  "pop rax")
-
 (defop (iken label-num) ()
   "pop rax"
   "test rax, rax"
@@ -108,97 +230,13 @@
 (defop (döngü label-num) (:indent 0)
   ("et_~a:" label-num))
 
-(defop < ()
-  "mov rcx, 0"
-  "mov rdx, 1"
-  "pop rbx"
-  "pop rax"
-  "cmp rax, rbx"
-  "cmovl rcx, rdx"
-  "push rcx")
-
-(defop > ()
-  "mov rcx, 0"
-  "mov rdx, 1"
-  "pop rbx"
-  "pop rax"
-  "cmp rax, rbx"
-  "cmovg rcx, rdx"
-  "push rcx")
-
-(defop bel ()
-  "push bel")
-
-(defop oku ()
-  "pop rax"
-  "xor rbx, rbx"
-  "mov bl, [rax]"
-  "push rbx")
-
-(defop yaz ()
-  "pop rbx"
-  "pop rax"
-  "mov [rax], bl")
-
-(defop (syscall num) ()
+(defop (syscall num) (:lex nil)
   (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"))))
 
-;;; (rbx rax -- rbx rax rbx)
-(defop üst ()
-  "pop rax"
-  "pop rbx"
-  "push rbx"
-  "push rax"
-  "push rbx")
-
-;;; (rcx rbx rax -- rbx rax rcx)
-(defop rot ()
-  "pop rax"
-  "pop rbx"
-  "pop rcx"
-  "push rbx"
-  "push rax"
-  "push rcx")
-
-;;; (rbx rax -- rax rbx)
-(defop değiş ()
-  "pop rax"
-  "pop rbx"
-  "push rax"
-  "push rbx")
-
-;;; (rbx rcx -- (:shl rbx cl))
-(defop << ()
-  "pop rcx"
-  "pop rbx"
-  "shl rbx, cl"
-  "push rbx")
-
-;;; (rbx rcx -- (:shr rbx cl))
-(defop >> ()
-  "pop rcx"
-  "pop rbx"
-  "shr rbx, cl"
-  "push rbx")
-
-;;; (rbx rcx -- (:or rbx cl))
-(defop "|" ()
-  "pop rax"
-  "pop rbx"
-  "or rbx, rax"
-  "push rbx")
-
-;;; (rbx rcx -- (:and rbx cl))
-(defop & ()
-  "pop rax"
-  "pop rbx"
-  "and rbx, rax"
-  "push rbx")
-
 (defun gen-header (op str)
   (format str "    ;; -- ~s --~%" op))