From 2d94db09901c346d1ac7f5787f89609b6ecf38dd Mon Sep 17 00:00:00 2001
From: mRnea <akannemre@gmail.com>
Date: Sat, 27 Jul 2024 11:58:41 +0300
Subject: changed . to dump, extended defop syntax, added while loops

---
 cl-forth.lisp | 85 +++++++++++++++++++++++++++++++++++------------------------
 1 file changed, 51 insertions(+), 34 deletions(-)

(limited to 'cl-forth.lisp')

diff --git a/cl-forth.lisp b/cl-forth.lisp
index f7ea66e..a87d0eb 100644
--- a/cl-forth.lisp
+++ b/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,13 +22,13 @@
         (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))
-                ((char= #\Space next-char) (read-char line-stream))
-                ((char= #\; next-char) ;; and not in string
-                 (finish))
-                (t (setf flag nil)))
+          (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))
+            (t (setf flag nil)))
           (when flag
             (incf col)
             (next-iteration)))
@@ -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,17 +111,19 @@
       (error "Can't generate program due to error during lexing"))
     (parse-tokens tokens)))
 
-;; (defun *ops* '(push pop minus dump))
-(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)))))
+;;; 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)))))
+  
+  (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)
@@ -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)))))
 
-- 
cgit v1.2.3