massive overhaul to defop, temporarily disable interpretation

1 files changed, 69 insertions, 84 deletions

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))