massive overhaul to defop, temporarily disable interpretation

2 files changed, 232 insertions, 209 deletions

diff --git a/assembly.lisp b/assembly.lisp
index e4582de..13623c7 100644
--- a/assembly.lisp
+++ b/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)))
-
-(defmacro defop (op-name+args (&key (indent 4)) &body body)
+        forms))
+
+  (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))
 
diff --git a/cl-forth.lisp b/cl-forth.lisp
index ab2da73..a22bb32 100644
--- a/cl-forth.lisp
+++ b/cl-forth.lisp
@@ -1,13 +1,5 @@
 (in-package :cl-forth)
 
-(eval-always
-  (defparameter *identifiers*
-    '(+ - dump = ise yoksa yap eş push değiş üst rot düş döngü iken < >
-      syscall-1 syscall-2 syscall-3 syscall-4 syscall-5 syscall-6
-      bel oku yaz >> << & "|"))
-  (defun is-identifier (sym)
-    (find sym *identifiers* :test #'string=)))
-
 (defun assembly-undefined-ops ()
   (iter (for (k) in-hashtable *operations*)
         (collect k into defops)
@@ -150,83 +142,76 @@
 
 
 ;;; INTERPRETER
-(eval-always
-  (define-condition op-not-implemented (style-warning)
-    ((undef-ops :initarg :ops :reader undef-ops))
-    (:report (lambda (condition stream)
-               (format stream "These ops are not defined in op-case: ~s"
-                       (undef-ops condition)))))
+;; (eval-always
+;;   (define-condition op-not-implemented (style-warning)
+;;     ((undef-ops :initarg :ops :reader undef-ops))
+;;     (:report (lambda (condition stream)
+;;                (format stream "These ops are not defined in op-case: ~s"
+;;                        (undef-ops condition)))))
   
-  (defun identifier-coverage (defined-ops)
-    (let ((undef-ops (set-difference *identifiers* defined-ops)))
-      (unless (null undef-ops)
-        (warn (make-condition 'op-not-implemented :ops undef-ops))))))
-
-(defmacro op-case (case-form &body body)
-  (iter (for (op-id) in body)
-        (when (not (is-identifier op-id))
-          (error "op-case: ~a is not an identifier" op-id))
-        (collect op-id into defined-ops)
-        (finally (identifier-coverage defined-ops)))
-  (let ((case-sym (gensym)))
-    `(let ((,case-sym ,case-form))
-       (case ,case-sym
-         ,@body
-         (otherwise (if (is-identifier (first ,case-sym))
-                        (error "op: ~a -- Not implemented yet"
-                               (first ,case-sym))
-                        (error "op: ~a -- Does not exist"
-                               (first ,case-sym))))))))
-
-(defun interpret-program (program)
-  (iter (with stack = (make-array 100 :fill-pointer 0 :adjustable t))
-        ;; (for op in-sequence program)
-        (for i from 0 below (length program))
-        (let ((op (aref program i)))
-          (op-case (first op)
-            (push (vector-push-extend (second op) stack))
-            (+ (vector-push-extend (+ (vector-pop stack)
-                                      (vector-pop stack))
-                                   stack))
-            (- (vector-push-extend (let ((top (vector-pop stack)))
-                                     (- (vector-pop stack) top))
-                                   stack))
-            (dump (print (vector-pop stack)))
-            (= (vector-push-extend (if (= (vector-pop stack)
-                                          (vector-pop stack))
-                                       1 0)
-                                   stack))
-            (yap (next-iteration))
-            (yoksa (setf i (second op)))
-            (ise (if (= (vector-pop stack) 1)
-                     nil
-                     (setf i (second op))))
-            (eş (let ((top (vector-pop stack)))
-                  (vector-push-extend top stack)
-                  (vector-push-extend top stack)))
-            (değiş (let* ((fst (vector-pop stack))
-                          (snd (vector-pop stack)))
-                     (vector-push-extend fst stack)
-                     (vector-push-extend snd stack)))
-            (düş (vector-pop stack))
-            (üst (let* ((fst (vector-pop stack))
-                        (snd (vector-pop stack)))
-                   (vector-push-extend snd stack)
-                   (vector-push-extend fst stack)
-                   (vector-push-extend snd stack)))
-            (rot (let* ((fst (vector-pop stack))
-                        (snd (vector-pop stack))
-                        (trd (vector-pop stack)))
-                   (vector-push-extend snd stack)
-                   (vector-push-extend fst stack)
-                   (vector-push-extend trd stack)))))))
-;; swap, değiş 
-;; dup, eş
-;; over, üst
-;; rot, rot
-;; drop, düşür
-
-
+;;   (defun identifier-coverage (defined-ops)
+;;     (let ((undef-ops (set-difference *identifiers* defined-ops)))
+;;       (unless (null undef-ops)
+;;         (warn (make-condition 'op-not-implemented :ops undef-ops))))))
+
+;; (defmacro op-case (case-form &body body)
+;;   (iter (for (op-id) in body)
+;;         (when (not (is-identifier op-id))
+;;           (error "op-case: ~a is not an identifier" op-id))
+;;         (collect op-id into defined-ops)
+;;         (finally (identifier-coverage defined-ops)))
+;;   (let ((case-sym (gensym)))
+;;     `(let ((,case-sym ,case-form))
+;;        (case ,case-sym
+;;          ,@body
+;;          (otherwise (if (is-identifier (first ,case-sym))
+;;                         (error "op: ~a -- Not implemented yet"
+;;                                (first ,case-sym))
+;;                         (error "op: ~a -- Does not exist"
+;;                                (first ,case-sym))))))))
+
+;; (defun interpret-program (program)
+;;   (iter (with stack = (make-array 100 :fill-pointer 0 :adjustable t))
+;;         ;; (for op in-sequence program)
+;;         (for i from 0 below (length program))
+;;         (let ((op (aref program i)))
+;;           (op-case (first op)
+;;             (push (vector-push-extend (second op) stack))
+;;             (+ (vector-push-extend (+ (vector-pop stack)
+;;                                       (vector-pop stack))
+;;                                    stack))
+;;             (- (vector-push-extend (let ((top (vector-pop stack)))
+;;                                      (- (vector-pop stack) top))
+;;                                    stack))
+;;             (dump (print (vector-pop stack)))
+;;             (= (vector-push-extend (if (= (vector-pop stack)
+;;                                           (vector-pop stack))
+;;                                        1 0)
+;;                                    stack))
+;;             (yap (next-iteration))
+;;             (yoksa (setf i (second op)))
+;;             (ise (if (= (vector-pop stack) 1)
+;;                      nil
+;;                      (setf i (second op))))
+;;             (eş (let ((top (vector-pop stack)))
+;;                   (vector-push-extend top stack)
+;;                   (vector-push-extend top stack)))
+;;             (değiş (let* ((fst (vector-pop stack))
+;;                           (snd (vector-pop stack)))
+;;                      (vector-push-extend fst stack)
+;;                      (vector-push-extend snd stack)))
+;;             (düş (vector-pop stack))
+;;             (üst (let* ((fst (vector-pop stack))
+;;                         (snd (vector-pop stack)))
+;;                    (vector-push-extend snd stack)
+;;                    (vector-push-extend fst stack)
+;;                    (vector-push-extend snd stack)))
+;;             (rot (let* ((fst (vector-pop stack))
+;;                         (snd (vector-pop stack))
+;;                         (trd (vector-pop stack)))
+;;                    (vector-push-extend snd stack)
+;;                    (vector-push-extend fst stack)
+;;                    (vector-push-extend trd stack)))))))
 
 ;;; COMPILER
 (defun write-program (program out &key (mem-cap 640000))