changed . to dump, extended defop syntax, added while loops

assembly.lisp

@@ -3,23 +3,38 @@
 (defparameter *operations* (make-hash-table))
 
 (eval-always
-  (defun normalize-op-list (lst)
+  (defun normalize-op-list (asm-list)
     (cons 'list
           (mapcar (lambda (el) (cond ((stringp el) el)
                                 ((listp el) `(format nil ,@el))))
-                  lst))))
+                  asm-list)))
 
-(defmacro defop (op-name (&key (indent 4) args) &body asm-strings)
+  (defun defop-format (str space-num asm-list)
+    (format str
+            (format nil "~~{~a~~a~~%~~}" 
+                    (make-string space-num :initial-element #\Space))
+            asm-list))
+
+  (defun replace-write (out-stream indent forms)
+    (if (consp forms)
+        (if (eq :write (car forms))
+            `(defop-format ,out-stream ,indent
+               ,(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)
+  (with-gensyms (out-stream)
+    (destructuring-bind (op-name . args) (mklist op-name+args)
       `(setf (gethash ',op-name *operations*)
-         (lambda (out-stream ,@args)
-           (format out-stream
-                   ,(format nil "~~{~a~~a~~%~~}" 
-                            (make-string indent :initial-element
-                                         #\Space))
-                   ,(normalize-op-list asm-strings)))))
+             (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))))))))
 
-
-(defop push (:args (a))
+(defop (push a) ()
   ("push ~d" a))
 
 (defop + ()
@@ -34,7 +49,7 @@
   "sub rbx, rax"
   "push rbx")
 
-(defop |.| ()
+(defop dump ()
   "pop rdi"
   "call dump")
 
@@ -47,23 +62,60 @@
   "cmove rcx, rdx"
   "push rcx")
 
-(defop exit (:args (exit-code))
+(defop (exit code) ()
   "mov rax, 60"
-  ("mov rdi, ~a" exit-code)
+  ("mov rdi, ~a" code)
   "syscall")
 
-(defop ise (:args (label-num))
+(defop (ise label-num) ()
   "pop rax"
   "test rax, rax"
   ("jz et_~a" label-num))
 
-(defop yoksa (:args (yap-num ise-num) :indent 0)
+(defop (yoksa yap-num ise-num) (:indent 0)
   ("    jmp et_~a" yap-num)
   ("et_~a:" ise-num))
 
-(defop yap (:args (label-num) :indent 0)
+(defop (yap label-num &optional döngü-num) (:indent 0)
+  (if (null döngü-num)
+      (:write ("et_~a:" label-num))
+      (:write ("    jmp et_~a" döngü-num)
+              ("et_~a:" label-num))))
+
+(defop eş ()
+  "pop rax"
+  "push rax"
+  "push rax")
+
+(defop düş ()
+  "pop rax")
+
+(defop (iken label-num) ()
+  "pop rax"
+  "test rax, rax"
+  ("jz et_~a" label-num))
+
+(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")
+
 (defun gen-code (op str)
   (let ((op-fn (gethash (car op) *operations*)))
     (if (null op-fn)

cl-forth.lisp

@@ -2,7 +2,7 @@
 
 (eval-always
   (defparameter *identifiers*
-    '(+ - |.| = ise yoksa yap eş push değiş üst rot düş))
+    '(+ - dump = ise yoksa yap eş push değiş üst rot düş döngü iken < >))
   (defun is-identifier (sym)
     (find sym *identifiers*)))
 
@@ -14,6 +14,7 @@
 (defun token-op (token)
   (car token))
 
+;;; LEXER
 (defun lex-line (line &optional (line-num 0))
   (iter (with line-stream = (make-string-input-stream line))
         (with col = 0)
@@ -21,9 +22,9 @@
         (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))
+          (cond ;; ((char= #\. next-char)
+            ;;  (collect (make-token '|.| line-num col) into tokens)
+            ;;  (read-char line-stream))
             ((char= #\Space next-char) (read-char line-stream))
             ((char= #\; next-char) ;; and not in string
              (finish))
@@ -64,34 +65,42 @@
                (appending tokens))))
      has-error)))
 
-;; (defun prog-from-tokens (tokens)
-;;   (iter (for token in tokens)
-;;         (let ((op (token-op token)))
-;;           (cond ((numberp op)
-;;                  (collect `(push ,op) result-type 'vector))
-;;                 (t (collect (list op) result-type 'vector))))))
-
+;;; PARSER
 (defun parse-tokens (tokens)
   (iter (with ops = (make-array (length tokens) :fill-pointer 0
                                                 :adjustable t))
-        (with if-stack = ())
+        (with stack = ())
         (for i from 0)
         (for token in tokens)
         (let ((op (token-op token)))
           (cond ((numberp op)
                  (vector-push-extend `(push ,op) ops))
                 ((eq 'ise op)
-                 (push i if-stack)
+                 (push (list 'ise i) stack)
                  (vector-push-extend (list 'ise nil) ops))
                 ((eq 'yoksa op)
-                 (let ((current (pop if-stack)))
-                   (setf (second (aref ops current)) i)
-                   (push i if-stack)
+                 (let ((top (pop stack)))
+                   (assert (eq 'ise (car top)))
+                   (setf (second (aref ops (cadr top))) i)
+                   (push (list 'yoksa i) stack)
                    (vector-push-extend (list 'yoksa nil i) ops)))
                 ((eq 'yap op)
-                 (let ((current (pop if-stack)))
-                   (setf (second (aref ops current)) i)
-                   (vector-push-extend (list 'yap i) ops)))
+                 (let ((top (pop stack)))
+                   (cond ((find (car top) (list 'yoksa 'ise))
+                          (setf (second (aref ops (cadr top))) i)
+                          (vector-push-extend (list 'yap i) ops))
+                         ((eq 'iken (car top))
+                          (setf (second (aref ops (cadr top))) i)
+                          (vector-push-extend (list 'yap i (third top)) ops))
+                         (t (error "yap cannot reference: ~a" (car top))))))
+                ((eq 'döngü op)
+                 (push (list 'döngü i) stack)
+                 (vector-push-extend (list 'döngü i) ops))
+                ((eq 'iken op)
+                 (let ((top (pop stack)))
+                   (assert (eq 'döngü (car top)))
+                   (push (list 'iken i (cadr top)) stack)
+                   (vector-push-extend (list 'iken nil) ops)))
                 (t (vector-push-extend (list op) ops))))
         (finally (return ops))))
 
@@ -102,7 +111,9 @@
       (error "Can't generate program due to error during lexing"))
     (parse-tokens tokens)))
 
-;; (defun *ops* '(push pop minus dump))
+
+;;; INTERPRETER
+(eval-always
   (define-condition op-not-implemented (style-warning)
     ((undef-ops :initarg :ops :reader undef-ops))
     (:report (lambda (condition stream)
@@ -112,7 +123,7 @@
   (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)))))
+        (warn (make-condition 'op-not-implemented :ops undef-ops))))))
 
 (defmacro op-case (case-form &body body)
   (iter (for (op-id) in body)
@@ -178,6 +189,9 @@
 ;; rot, rot
 ;; drop, düşür
 
+
+
+;;; COMPILER
 (defun gen-header (op str)
   (format str "    ;; -- ~s --~%" op))
 
@@ -203,5 +217,8 @@
 (defun compile-program (path)
   (generate-program (make-program path) :compile t))
 
-
+(defun assembly-undefined-ops ()
+  (iter (for (k) in-hashtable *operations*)
+        (collect k into defops)
+        (finally (return (set-difference *identifiers* defops)))))