From 025c958e2f8b1499f23a5ae1c1be23452572b326 Mon Sep 17 00:00:00 2001
From: mRnea <akannemre@gmail.com>
Date: Wed, 24 Jul 2024 12:09:26 +0300
Subject: branching (if else) added, as interpretation and compilation

---
 assembly.lisp | 41 ++++++++++++++++++++++++++++++++++++++---
 cl-forth.lisp | 26 +++++++++++++++-----------
 2 files changed, 53 insertions(+), 14 deletions(-)

diff --git a/assembly.lisp b/assembly.lisp
index 3e80686..bdee15c 100644
--- a/assembly.lisp
+++ b/assembly.lisp
@@ -9,14 +9,17 @@
                                 ((listp el) `(format nil ,@el))))
                   lst))))
 
-(defmacro defop (op-name args &body asm-strings)
+(defmacro defop (op-name (&key (indent 4) args) &body asm-strings)
   `(setf (gethash ',op-name *operations*)
          (lambda (out-stream ,@args)
-           (format out-stream "~{    ~a~%~}"
+           (format out-stream
+                   ,(format nil "~~{~a~~a~~%~~}" 
+                            (make-string indent :initial-element
+                                         #\Space))
                    ,(normalize-op-list asm-strings)))))
 
 
-(defop push (a)
+(defop push (:args (a))
   ("push ~d" a))
 
 (defop + ()
@@ -35,6 +38,38 @@
   "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 (:args (exit-code))
+  "mov rax, 60"
+  ("mov rdi, ~a" exit-code)
+  "syscall")
+
+(defop ise (:args (label-num))
+  "pop rax"
+  "test rax, rax"
+  ("jz et_~a" label-num))
+
+(defop yoksa (:args (yap-num ise-num) :indent 0)
+  ("    jmp et_~a" yap-num)
+  ("et_~a:" ise-num))
+
+(defop yap (:args (label-num) :indent 0)
+  ("et_~a:" label-num))
+
+(defun gen-code (op str)
+  (let ((op-fn (gethash (car op) *operations*)))
+    (if (null op-fn)
+        (error "~s is not a valid op" op)
+        (apply op-fn str (cdr op)))))
+
 (defun gen-dump (str)
   (format str "~{~a~%~}"
           '("dump:"
diff --git a/cl-forth.lisp b/cl-forth.lisp
index 14b6573..f7ea66e 100644
--- a/cl-forth.lisp
+++ b/cl-forth.lisp
@@ -74,16 +74,24 @@
 (defun parse-tokens (tokens)
   (iter (with ops = (make-array (length tokens) :fill-pointer 0
                                                 :adjustable t))
+        (with if-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)
-                 (vector-push-extend
-                  `(ise ,(position 'yap tokens :start i :key #'token-op))
-                  ops))
-                ;; currently does not handle nesting
+                 (push i if-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)
+                   (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)))
                 (t (vector-push-extend (list op) ops))))
         (finally (return ops))))
 
@@ -141,6 +149,7 @@
                                        1 0)
                                    stack))
             (yap (next-iteration))
+            (yoksa (setf i (second op)))
             (ise (if (= (vector-pop stack) 1)
                      nil
                      (setf i (second op))))
@@ -184,13 +193,8 @@
                              "_start:"))
     (iter (for op in-sequence program)
           (gen-header op out)
-          (let ((op-fn (gethash (car op) *operations*)))
-            (if (null op-fn)
-                (format t "~s is not an op" (car op))
-                (apply op-fn out (cdr op)))))
-    (format out "~{~a~%~}" '("    mov rax, 60"
-                             "    mov rdi, 0"
-                             "    syscall")))
+          (gen-code op out))
+    (gen-code '(exit 0) out))
   (when compile
     (run `("nasm" "-felf64" ,path))
     (let ((name (first (uiop:split-string path :separator '(#\.)))))
-- 
cgit v1.2.3